#| -*-Scheme-*-

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
    2017, 2018, 2019, 2020 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

|#

;;;; C Declarations
;;; package: (ffi)


(define-structure (c-includes (conc-name c-includes/)
			      (constructor make-c-includes (library))
			      ;; To be fasdump/loadable.
			      (type vector) (named 'c-includes))
  library	; String naming the DLL of trampolines (the shim).
  (files	'()) ;; Included file names and their modtimes when read.
  (type-names	'()) ;; E.g. ((gpointer (* mumble) . "prhello.cdecl")...)
  (structs	'()) ;; E.g. ((|_GdkColor| (struct ...) . "gdkcolor.cdecl")...)
  (unions	'()) ;; E.g. ((|_GdkEvent| (union ...) . "gdkevents.cdecl")...)
  (enums	'()) ;; E.g. ((|_cairo_status| (enum ...) . "cairo.cdecl")...)
  (enum-constants'()) ;;E.g. ((|CAIRO_STATUS_SUCCESS| . "prhello.cdecl")...)
  (callouts	'()) ;; E.g. ((|gdk_window_new| . #<alien-function 42...>)...)
  (callbacks	'()) ;; E.g. ((|delete_event| . #<alien-function 42...>)...)
  (enum-values	'()) ;; E.g. ((|CAIRO_STATUS_SUCCESS| . 0)...) from groveler.
  (struct-values'()) ;; List of struct info from the groveler:
  ;;                    (((sizeof |GdkColor|) . 12)
  ;;                     ((offset |GdkColor| pixel) . (0 . int))
  ;;                     ((offset |GdkColor| red) . (4 . short))
  ;;                     ((offset |GdkColor| green) . (6 . short))
  ;;                     ((offset |GdkColor| blue) . (8 . short))
  ;;                     ((sizeof (struct |_GdkColor|)) . 12)
  ;;                     ((offset (struct |_GdkColor|) pixel) . (0 . int))
  ;;                     ((offset (struct |_GdkColor|) red) . (4 . short))
  ;;                     ((offset (struct |_GdkColor|) green) . (6 . short))
  ;;                     ((offset (struct |_GdkColor|) blue) . (8 . short))...)
  )

(define (include-cdecls library)
  ;; Toplevel entry point for the generator.
  ;; Returns a new c-includes structure.
  (let ((includes (make-c-includes library))
	(cwd (if (param:loading?)
		 (directory-pathname (current-load-pathname))
		 (working-directory-pathname))))
    (fluid-let ((c-include-noisily? #t))
      (include-cdecl-file library cwd cwd includes))
    includes))

(define c-include-noisily? #f)
(define current-filename)

(define (include-cdecl-file filename cwd twd includes)
  ;; Adds the C declarations in filename to includes.  Interprets
  ;; filename relative to cwd (current working directory).
  ;; Abbreviates namestrings under twd (topmost working, build directory).

  (let* ((pathname (->simple-pathname
		    (merge-pathnames (pathname-default-type filename "cdecl")
				     cwd)))
	 (new-cwd (directory-pathname pathname))
	 (namestring (enough-namestring pathname twd))
	 (modtime (file-modification-time-indirect namestring))
	 (files (c-includes/files includes)))
    (if (not (assoc namestring files))
	(fluid-let ((current-filename namestring))
	  (set-c-includes/files! includes
				 (cons (cons namestring modtime) files))

	  (define (kernel)
	    (call-with-input-file namestring
	      (lambda (inport)
		(let loop ()
		  (let ((form
			 (parameterize ((param:reader-fold-case? #f))
			   (read inport))))
		    (if (not (eof-object? form))
			(begin
			  (include-cdecl form new-cwd twd includes)
			  (loop))))))))

	  (if c-include-noisily?
	      (with-notification (lambda (port)
				   (write-string "Including " port)
				   (write-string namestring port))
				 kernel)
	      (kernel))))))

(define (->simple-pathname pathname)
  (let loop ((count 0)
	     (simpler (pathname-simplify pathname)))
    (let ((again (pathname-simplify simpler)))
      (cond ((fix:> count 100) (error "Could not simplify:" pathname))
	    ((pathname=? again simpler) again)
	    (else (loop again (fix:1+ count)))))))

(define (include-cdecl form cwd twd includes)
  ;; Add a top-level C declaration to includes.  If it is an
  ;; include, interprete the included filenames relative to cwd
  ;; (current working directory).
  (if (not (and (pair? form) (symbol? (car form)) (pair? (cdr form))))
      (cerror form "malformed top level C declaration"))
  (let ((keyword (car form))
	(name (cadr form))
	(rest (cddr form)))
    (case keyword
      ((|include|)
       (for-each (lambda (file) (include-cdecl-file file cwd twd includes))
		 (cdr form)))
      ((|typedef|) (include-typedef form name rest includes))
      ((|struct|) (include-struct form name rest includes))
      ((|union|) (include-union form name rest includes))
      ((|enum|) (include-enum form name rest includes))
      ((|extern|) (include-function form name rest includes))
      ((|callback|) (include-function form name rest includes))
      (else (cerror form "unknown top level keyword"))))
  unspecific)

(define (include-typedef form name rest includes)
  ;; Add a top-level (typedef name . rest) C declaration to includes.
  (if (not (and (symbol? name)
		(pair? rest) (null? (cdr rest))))
      (cerror form "malformed typedef declaration"))
  (let* ((ctypes (c-includes/type-names includes))
	 (entry (assq name ctypes)))
    (if entry (cerror form "already defined in " (cddr entry)))
    (let* ((ctype (valid-ctype (car rest) includes))
	   (new (cons name (cons ctype current-filename))))
      (set-c-includes/type-names! includes (cons new ctypes))
      unspecific)))

(define (include-struct form name members includes)
  ;; Add a top-level (struct name . members) C declaration to includes.
  (if (not (and (symbol? name) (pair? members) (list? members)))
      (cerror form "malformed named struct declaration"))
  (let* ((structs (c-includes/structs includes))
	 (entry (assq name structs)))
    (if entry (cerror form "already defined in " (cddr entry)))
    (let* ((anon (cons 'struct
		       (map (lambda (member)
			      (valid-struct-member member includes))
			    members)))
	   (info (cons anon current-filename)))
      (set-c-includes/structs!
       includes (cons (cons name info) structs))
      unspecific)))

(define (valid-struct-member form includes)
  ;; Returns (name . ctype) given a member C declaration.
  ;; Adds any internal named struct/union/enum types to includes.
  (if (not (and (pair? form) (symbol? (car form))
		(pair? (cdr form)) (null? (cddr form))))
      (cerror form "malformed struct member"))
  (let ((name (car form))
	(ctype (valid-ctype (cadr form) includes)))
    (cons name ctype)))

(define (include-union form name members includes)
  ;; Add a top-level (union name . members) C declaration to includes.
  (if (not (and (symbol? name) (pair? members) (list? members)))
      (cerror form "malformed named union declaration"))
  (let* ((unions (c-includes/unions includes))
	 (entry (assq name unions)))
    (if entry (cerror form "already defined in " (cddr entry)))
    (let* ((anon (cons 'union
		       (map (lambda (member)
			      (valid-union-member member includes))
			    members)))
	   (info (cons anon current-filename)))
      (set-c-includes/unions!
       includes (cons (cons name info) unions))
      unspecific)))

(define (valid-union-member form includes)
  ;; Returns (name . ctype) given a member C declaration.
  ;; Adds any internal named struct/union/enum types to includes.
  (if (not (and (pair? form) (symbol? (car form))
		(pair? (cdr form)) (null? (cddr form))))
      (cerror form "malformed union member"))
  (let ((name (car form))
	(ctype (valid-ctype (cadr form) includes)))
    (cons name ctype)))

(define (include-enum form name constants includes)
  ;; Add a top-level (enum name . constants) C declaration to includes.
  ;; Also accepts an unnamed (enum . constants) C declaration.
  (if (not (list? constants))
      (cerror form "malformed named enum declaration"))
  (if (symbol? name)
      (let* ((enums (c-includes/enums includes))
	     (entry (assq name enums)))
	(if entry (cerror form "already defined in " (cddr entry)))
	(let* ((anon (cons 'enum
			   (valid-enum-constants constants includes)))
	       (info (cons anon current-filename)))
	  (set-c-includes/enums!
	   includes (cons (cons name info) enums))))
      (valid-enum-constants (cdr form) includes)))

(define (valid-enum-constants forms includes)
  ;; Returns a list of (name) pairs for each enum constant declaration
  ;; in forms.  Also adds enum constants to includes.
  (let loop ((forms forms))
    (if (null? forms) '()
	(let ((name (valid-enum-constant (car forms) includes)))
	  (cons name (loop (cdr forms)))))))

(define (valid-enum-constant form includes)
  ;; Returns (name), the name of the validated enum constant declared
  ;; by form.  Immediately adds the constant to the list in includes,
  ;; checking that it is not already there.
  (if (not (and (pair? form) (symbol? (car form))
		;; 1 or 2 args
		(or (null? (cdr form))
		    (and (pair? (cdr form)) (null? (cddr form))))))
      (cerror form "malformed enum constant declaration"))
  (if (pair? (cdr form))
      (cwarn (cadr form) "ignored enum value"))
  (let* ((name (car form))
	 (constants (c-includes/enum-constants includes))
	 (entry (assq name constants)))
    (if entry (cerror form "already defined in " (cdr entry)))
    (set-c-includes/enum-constants!
     includes (cons (cons name current-filename) constants))
    (list name)))

(define (include-function form rettype rest includes)
  ;; Callouts/backs have much in common here, thus this shared
  ;; procedure, which uses the keyword still at the head of form to
  ;; munge the correct alist in includes.
  (if (not (and (pair? rest) (symbol? (car rest))
		(list? (cdr rest))))
      (cerror form "malformed " (symbol->string (car form)) " declaration"))
  (let* ((name (car rest))
	 (params (cdr rest))
	 (others (if (eq? 'extern (car form))
		     (c-includes/callouts includes)
		     (c-includes/callbacks includes)))
	 (entry (assq name others)))
    (if entry (cerror form "already defined in "
		      (alien-function/filename (cdr entry))))
    (let ((new (cons name
		     (make-alien-function
		      (symbol->string name)
		      (c-includes/library includes)
		      (valid-ctype rettype includes)
		      (valid-params params includes)
		      current-filename))))
      (if (eq? 'extern (car form))
	  (set-c-includes/callouts! includes (cons new others))
	  (set-c-includes/callbacks! includes (cons new others)))
      unspecific)))

(define (valid-params forms includes)
  ;; Returns a list -- (name ctype) for each parameter declaration
  ;; form in forms.
  (if (null? forms) '()
      (cons (valid-param (car forms) includes)
	    (valid-params (cdr forms) includes))))

(define (valid-param form includes)
  ;; Returns (name ctype) after validating form.
  (if (not (and (pair? form) (symbol? (car form))
		(pair? (cdr form))
		(null? (cddr form))))
      (cerror form "malformed parameter declaration"))
  (if (string-find-next-char-in-set
       (symbol->string (car form)) char-set:not-c-symbol)
      (cerror form "invalid parameter name"))
  (let ((name (car form))
	(ctype (valid-ctype (cadr form) includes)))
    (list name ctype)))

(define char-set:not-c-symbol (char-set-invert
			       (char-set-union (char-set #\_)
					       char-set:alphanumeric)))

(define (valid-ctype form includes)
  ;; Returns a valid ctype expression, a copy of form.  Modifies
  ;; includes with any internal struct/union/enum declarations.
  (cond ((symbol? form) form)
	((ctype/pointer? form) form)
	((ctype/const? form)
	 (list 'const (valid-ctype (cadr form) includes)))

	((ctype/struct-name? form) form)
	((ctype/struct-anon? form)
	 (cons 'struct (map (lambda (member)
			      (valid-struct-member member includes))
			    (cdr form))))
	((ctype/struct-named? form)
	 (include-struct form (cadr form) (cddr form) includes)
	 (list 'struct (cadr form)))

	((ctype/union-name? form) form)
	((ctype/union-anon? form)
	 (cons 'union (map (lambda (member)
			     (valid-union-member member includes))
			   (cdr form))))
	((ctype/union-named? form)
	 (include-union form (cadr form) (cddr form))
	 (list 'union (cadr form)))

	((ctype/enum-name? form) form)
	((ctype/enum-anon? form)
	 (cons 'enum (valid-enum-constants (cdr form) includes)))
	((ctype/enum-named? form)
	 (include-enum form (cadr form) (cddr form) includes)
	 (list 'enum (cadr form)))

	((ctype/array? form)
	 (list 'array
	       (valid-ctype (ctype-array/element-type form) includes)
	       (ctype-array/size form)))

	(else (cerror form "bogus C type declaration"))))

(define condition-type:cerror
  (make-condition-type
   'ffi-cdecl-error
   condition-type:error
   '(form filename message)
   (lambda (condition port)
     (write-string "Error: " port)
     (write-string (access-condition condition 'message) port)
     (write-string ":" port)
     (write-string (access-condition condition 'filename) port)
     (write-string ": " port)
     (write (access-condition condition 'form) port))))

(define cerror
  (let ((signaller (condition-signaller condition-type:cerror
					'(form filename message)
					standard-error-handler)))
    (named-lambda (cerror form message . args)
      (signaller form current-filename
		 (apply string-append
			(map (lambda (obj)
			       (if (string? obj) obj (write-to-string obj)))
			     (cons message args)))))))

(define condition-type:cwarn
  (make-condition-type
   'ffi-cdecl-warning
   condition-type:warning
   '(form filename message)
   (lambda (condition port)
     (write-string (access-condition condition 'message) port)
     (write-string ":" port)
     (write-string (access-condition condition 'filename) port)
     (write-string ": " port)
     (write (access-condition condition 'form) port))))

(define cwarn
  (let ((signaller (condition-signaller condition-type:cwarn
					'(form filename message)
					standard-warning-handler)))
    (named-lambda (cwarn form message . args)
      (with-simple-restart 'muffle-warning "Ignore warning."
        (lambda ()
	  (signaller form current-filename
		     (apply string-append
			    (map (lambda (obj)
				   (if (string? obj) obj (write-to-string obj)))
				 (cons message args)))))))))