;;; C Declaration Language

;*              Copyright 1989 Digital Equipment Corporation
;*                         All Rights Reserved
;*
;* Permission to use, copy, and modify this software and its documentation is
;* hereby granted only under the following terms and conditions.  Both the
;* above copyright notice and this permission notice must appear in all copies
;* of the software, derivative works or modified versions, and any portions
;* thereof, and both notices must appear in supporting documentation.
;*
;* Users of this software agree to the terms and conditions set forth herein,
;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
;* right and license under any changes, enhancements or extensions made to the
;* core functions of the software, including but not limited to those affording
;* compatibility with other hardware or software environments, but excluding
;* applications which incorporate this software.  Users further agree to use
;* their best efforts to return to Digital any such changes, enhancements or
;* extensions that they make and inform Digital of noteworthy uses of this
;* software.  Correspondence should be provided to Digital at:
;* 
;*                       Director of Licensing
;*                       Western Research Laboratory
;*                       Digital Equipment Corporation
;*                       100 Hamilton Avenue
;*                       Palo Alto, California  94301  
;* 
;* This software may be distributed (but not offered for sale or transferred
;* for compensation) to third parties, provided such third parties agree to
;* abide by the terms and conditions of this notice.  
;* 
;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
;* SOFTWARE.

;;; This module compile type declarations.
;;;
;;; Data types are defined by this type of expression.  Initially, we'll
;;; try to accept as few forms as possible by doing a little "hand casting".
;;; The legal forms are:
;;;
;;;	(typedef <type> <identifier>)
;;;
;;; where:
;;;
;;;	<type> ::= (<stype> *)
;;;		   (<stype> *proc)
;;;
;;;	<atype> ::= (<stype> integer)
;;;		    <struct-or-union-specifier>
;;;
;;;	<stype> ::= char
;;;		    shortint
;;;		    shortunsigned
;;;		    int
;;;		    unsigned
;;;		    float
;;;		    double
;;;		    <type-def-name>
;;;
;;;	<type-def-name> ::= <identifier> denoting another type
;;;
;;;	<struct-or-union-specifier> ::=	( struct [<struct-decl> ...] )
;;;					( union  [<struct-decl> ...] )
;;;
;;;	<struct-decl> ::= ( <atype> <identifier> )

(module typedef)

;;; Type definition expressions from the input file are parsed by the
;;; following expression.  It will return the type name on success, or
;;; call error on an error.

(define (INPUT-TYPEDEF exp)
    (if (and (= (length exp) 3) (eq? (car exp) 'typedef) (symbol? (caddr exp)))
	(let ((id (caddr exp))
	      (parse (parse-type (cadr exp))))
	     (putprop id 'base-type #f)
	     (putprop id 'type parse)
	     (if (and (pair? parse) (symbol? (car parse))
		      (eq? (cadr parse) '*))
		 (putprop (car parse) 'pointed-to-by id))
	     id)
	(error 'input-typedef "Illegal syntax: ~s" exp)))

;;; Type declarations are parsed by the following function.  It will return
;;; the type definition, or call error on an error.  Some of these type
;;; transformations may be MACHINE DEPENDENT.

(define (PARSE-TYPE type)
    (if (pair? type)
	(cond ((memq (car type) '(struct union))
	       (struct-or-union type))
	      ((equal? (cdr type) '(*))
	       (list (parse-stype (car type)) '*))
	      ((equal? (cdr type) '(*proc))
	       (list (parse-stype (car type)) '*proc))
	      (else (parse-atype type)))
	(parse-stype type)))

(define (PARSE-ATYPE type)
    (if (pair? type)
	(cond ((memq (car type) '(struct union))
	       (struct-or-union type))
	      ((and (= (length type) 2)
		   (integer? (cadr type)) (>= (cadr type) 0))
	       (list (parse-stype (car type)) (cadr type)))
	      (else (error 'parse-atype "Argument is not a legal type: ~s"
			   type)))
	(parse-stype type)))

(define (PARSE-STYPE type)
    (if (symbol? type)
	type
	(error 'parse-stype "Argument is not a legal type: ~s" type)))

;;; Structs and unions are handled by the following functions.

(define (STRUCT-OR-UNION exp)
    (list (case (car exp)
		((struct) 'struct)
		((union) 'union)
		(else (error 'struct-or-union "Illegal syntax: ~s" exp)))
	  (map (lambda (slot)
		       (if (and (= (length slot) 2) (symbol? (cadr slot)))
			   (list (parse-slot-type (car slot)) (cadr slot))
		           (error 'struct-or-union
				  "Argument is not a legal slot: ~s" slot)))
	       (cdr exp))))

;;; When the type specifier for a slot is parsed, it may be contain an
;;; array or structure definition, or a symbol.  Arrays and structures
;;; defined here must have a dummy type assigned to them.

(define PARSE-SLOT-TYPE
    (let ((uid 1))
	 (lambda (type)
		 (let ((parse (parse-atype type)))
		      (if (symbol? parse)
			  parse
			  (let ((symbol
				 (string->symbol (format "*TYPE~s" uid))))
			       (set! uid (+ uid 1))
			       (putprop symbol 'base-type #f)
			       (putprop symbol 'type parse)
			       symbol))))))

;;; The base types recognized by the type system are known to C and have
;;; known bytes sizes WHICH MAY BE MACHINE DEPENDENT.

(for-each
    (lambda (x)
	    (let ((type (list-ref x 0))
		  (size (list-ref x 1))
		  (to-ref (list-ref x 2))
		  (to-set! (list-ref x 3)))
		 (putprop type 'type #t)
		 (putprop type 'base-type type)
		 (putprop type 'size size)
		 (putprop type 'to-get to-ref)
		 (putprop type 'to-set! to-set!)))

    ;  C type	  	size  	to access		to set!

    '((char          	1 	c-byte-ref		c-byte-set!)
      (shortint      	2 	c-shortint-ref		c-shortint-set!)
      (shortunsigned	2 	c-shortunsigned-ref 	c-shortunsigned-set!)
      (int		4 	c-int-ref	    	c-int-set!)
      (unsigned		4	c-unsigned-ref		c-unsigned-set!)
      (pointer		4	c-unsigned-ref		c-unsigned-set!)
      (procedure	4	c-unsigned-ref		c-unsigned-set!)
      (float		4	c-float-ref		c-float-set!)
      (double		8	c-double-ref		c-double-set!)))

;;; Every type symbol can be resolved into a base type symbol by the following
;;; function.  Once a base type has been computed, it is saved on the
;;; property list.

(define (BASE-TYPE start-type)
    (or (getprop start-type 'base-type)
	(let loop ((type start-type) (count 20))
	     (let ((typeinfo (getprop type 'type)))
		  (if (or (not typeinfo) (eq? count 0))
		      (error 'base-type "BASE TYPE cannot be resolved: ~s"
			     start-type))
		  (if (symbol? typeinfo)
		      (loop typeinfo (- count 1))
		      (putprop start-type 'base-type type))))))

;;; Basic information about a type is returned by:

(define (ISA-UNION? type)
    (let ((typeinfo (getprop (base-type type) 'type)))
	 (and (pair? typeinfo) (eq? (car typeinfo) 'union))))

(define (ISA-STRUCT? type)
    (let ((typeinfo (getprop (base-type type) 'type)))
	 (and (pair? typeinfo) (eq? (car typeinfo) 'struct))))

(define (UORS-SLOTS type) (cadr (getprop (base-type type) 'type)))

(define (ISA-PROCP? type)
    (let ((typeinfo (getprop (base-type type) 'type)))
	 (and (pair? typeinfo) (eq? (cadr typeinfo) '*proc))))

(define (PROCP-RETURNS type)
    (base-type (car (getprop (base-type type) 'type))))

(define (ISA-POINTER? type)
    (let ((typeinfo (getprop (base-type type) 'type)))
	 (and (pair? typeinfo) (eq? (cadr typeinfo) '*))))

(define (POINTER-TO type)
    (base-type (car (getprop (base-type type) 'type))))

(define (ISA-ARRAY? type)
    (let ((typeinfo (getprop (base-type type) 'type)))
	 (and (pair? typeinfo) (number? (cadr typeinfo)))))

(define (ARRAY-SIZE type) (cadr (getprop (base-type type) 'type)))

(define (ARRAY-TYPE type) (base-type (car (getprop (base-type type) 'type))))

(define (POINTED-TO-BY type)
    (base-type (getprop (base-type type) 'pointed-to-by)))

;;; Given this information, we can now compute sizes of things.  There may
;;; be future MACHINE DEPENDENT problems here as we aren't worrying about
;;; alignment.

(define (SIZE-OF type)
    
    (define (SIZE-OF-SU slots func)
	    (let ((size 0))
		 (for-each
		     (lambda (slot)
			     (set! size (func size (size-of (car slot)))))
		     slots)
		 size))
    
    (cond ((getprop (base-type type) 'size))
	  ((isa-union? type) (size-of-su (uors-slots type) max))
	  ((isa-struct? type) (size-of-su (uors-slots type) +))
	  ((isa-procp? type) (size-of 'procedure))
	  ((isa-pointer? type) (size-of 'pointer))
	  ((isa-array? type) (* (array-size type) (size-of (array-type type))))
	  (else (error 'size-of "Mystery type: ~s" type))))

;;; A method for loading a type which takes an object, an offset, and an
;;; index (only for arrays) as it's arguments is returned by the following
;;; function.

(define (TO-GET-TYPE type)
    (let ((base (base-type type)))
	 (cond ((getprop base 'to-get))
	       ((isa-array? base)
		`(lambda (x y i)
			 (,(to-get-type (array-type base)) x
			  (+ y (* ,(size-of (array-type base)) i)))))
	       ((isa-pointer? base)
		`(lambda (x y)
			 (cons ',base
			       (,(to-get-type 'pointer) x y))))
	       ((isa-procp? base)
		`(lambda (x y)
			 (cons ',base (,(to-get-type 'pointer) x y))))
	       (else #f))))

;;; A method for storing a type which takes an object, an offset, an index
;;; (only for arrays), and a new value as it's arguments is returned by the
;;; following function.

(define (TO-SET!-TYPE type)
      (let ((base (base-type type)))
	 (cond ((getprop base 'to-set!))
	       ((isa-array? base)
		`(lambda (x y i z)
			 (,(to-set!-type (array-type base)) x
			  (+ y (* ,(size-of (array-type base)) i))
			  (,(to-check-type (array-type base)) z))))
	       ((isa-pointer? base)
		`(lambda (x y z)
			 (,(to-set!-type 'pointer) x y
			  (,(to-check-type  base) z))))
	       ((isa-procp? base)
		`(lambda (x y z)
			 (,(to-set!-type 'pointer) x y
			  (,(to-check-type base) z))))
	       (else #f))))

;;; A method for checking a type and returning the "raw" value which takes an
;;; object as it's argument is returned by the following function.

(define (TO-CHECK-TYPE type)
    (let ((base (base-type type)))
	 (if (or (isa-pointer? base) (isa-procp? base))
	     (uis "CHK-" base)
	     '(lambda (x) x))))

;;; The symbol that is used as the type tag for objects is returned by the
;;; following procedure.  It returns #f when there is no type tag.

(define (TYPE-TAG type)
    (let ((base (base-type type)))
	 (if (or (isa-pointer? base) (isa-procp? base))
	     base
	     #f)))

;;; Converts a list of strings or symbols into an upper-case uninterned symbol.

(define (UIS . syms)
    (string->uninterned-symbol
	(list->string
	    (let loop ((syms syms))
		 (if syms
		     (append (map char-upcase
				  (string->list
				      (if (symbol? (car syms))
					  (symbol->string (car syms))
					  (car syms))))
			     (loop (cdr syms)))
		     '())))))

;;; Scheme code for type definitions is emitted by the following procedure
;;; which is called with a list of all type names, a list of definition
;;; only types, and a list of read-only types, and the filename/modulename
;;; prefix.

(define (EMIT-TYPEDEFS types define-only read-only type-file-root)
    (let ((check (open-output-file (string-append type-file-root ".sc")))
	  (external (open-output-file (string-append type-file-root ".sch")))
	  (type-module (uis type-file-root)))
	 
	 (define (EMIT-TYPE type read-only)
		 (cond ((isa-pointer? type)
			(emit-chk-procs type def-print)
			(cond ((or (isa-union? (pointer-to type))
				   (isa-struct? (pointer-to type)))
			       (emit-struct-procs type read-only
				   type-file-root))
			      ((isa-array? (pointer-to type))
			       (emit-array-procs type read-only def-print))))
		       ((isa-procp? type)
			(emit-chk-procs type def-print))))
	 
	 (define (DEF-PRINT exp)
		 (pp exp check)
		 (newline check)
		 (pp `(define-external ,(cadr exp) ,type-module) external)
		 (newline external))
	 
	 (format check "(module ~a)~%~%" type-module)
	 (for-each
	     (lambda (type)
		     (unless (or (memq type define-only)
				 (not (eq? type (base-type type))))
			     (emit-type type (memq type read-only))))
	     types)
	 (close-port check)
	 (close-port external)))	    

;;; Checking functions for procedure pointer types are emitted by the
;;; following procedure.  The arguments are the object type and the procedure
;;; to print the definitions.

(define (EMIT-CHK-PROCS type def-print)
    (def-print `(define (,(uis "CHK-" (type-tag type)) x)
			(if (and (pair? x) (eq? (car x) ',(type-tag type)))
			    (cdr x)
			    (error ',(uis "CHK-" (type-tag type))
				   "Argument is incorrect type: ~s" x))))
    (def-print `(define (,(uis "ISA-" (type-tag type) "?") x)
			(and (pair? x) (eq? (car x) ',(type-tag type))))))

;;; Access functions for array types are generated by the following procedure.
;;; The arguments are the object type, a read-only flag, and the function to
;;; print the definitions.

(define (EMIT-ARRAY-PROCS pointer read-only def-print)
    (let* ((type (pointer-to pointer))
	   (size (array-size type))
	   (entry-type (array-type type))
	   (chk (to-check-type pointer)))
	  (def-print `(define (,(uis type "-LENGTH") x)
			      (quotient (string-length (,chk x))
				  ,(size-of entry-type))))
	  (cond ((or (isa-struct? entry-type) (isa-union? entry-type))
		 (def-print
		     `(define (,(uis type "->" entry-type "-LIST") x)
			      (let* ((array (,chk x))
				     (asize (string-length array))
				     (esize ,(size-of entry-type)))
				    (let loop ((x 0))
					 (if (eq? x asize)
					     '()
					     (cons (cons ',(pointed-to-by
							       entry-type)
							 (substring array
							     x (+ x esize)))
						   (loop (+ x esize))))))))
		 (def-print
		     `(define (,(uis entry-type "-LIST->" type) x)
			      (cons ',pointer
				    (apply string-append
					   (map ,(to-check-type
						     (pointed-to-by
							 entry-type))
						x))))))
		(else
		 (def-print `(define (,type x i)
				     (,(to-get-type type) (,chk x) 0 i)))
		 (def-print
		     `(define (,(uis type "->" entry-type "-LIST") x)
			      (let loop ((i 0)
					 (count (,(uis type "-LENGTH") x)))
				   (if (eq? i count)
				       '()
				       (cons (,type x i)
					     (loop (+ i 1) count))))))
		 (def-print
		     `(define (,(uis entry-type "-LIST->" type) l)
			      (let loop ((l l)
					 (i 0)
					 (a (,(uis "MAKE-" type)
					     ,@(if (eq? size 0)
						   '((length l))
						   '()))))
				   (if l
				       (begin (,(uis type "!") a i (car l))
					      (loop (cdr l) (+ i 1) a))
				       a))))
		 (def-print
		     `(define (,(uis type "!") x i z)
			      (,(to-set!-type type) (,chk x) 0 i z)))
		 (def-print
		     `(define (,(uis "MAKE-" type)
			       ,@(if (eq? size 0) '(x) '()))
			      (cons ',pointer
				    (make-string
					(* ,(size-of entry-type)
					   ,(if (eq? size 0) 'x	size))
					(integer->char 0)))))))))

;;; Write the source file containing the struct definition.  

(define (EMIT-STRUCT-PROCS pointer read-only type-file-root)
    (let* ((type (pointer-to pointer))
	   (slots (uors-slots type)))
	  (if slots
	      (let* ((type-module (list->string
				      (map char-downcase
					   (string->list
					       (symbol->string type)))))
		     (code-port (open-output-file
				    (string-append type-module ".sc")))
		     (extern-port (open-output-file
				      (string-append type-module ".sch"))))
		    
		    (define (DEF-PRINT exp)
			    (pp exp code-port)
			    (newline code-port)
			    (format extern-port "(define-external ~s ~a)~%"
				    (cadr exp) type-module))
		    
		    (format code-port "(module ~a)~%" type-module)
		    (format code-port "(include ~s)~%"
			    (string-append type-file-root ".sch"))
		    (def-print `(define (,(uis "MAKE-" type))
					(cons ',pointer
					      (make-string
						  ,(* (quotient
							  (+ (size-of type) 3)
							  4)
						      4)
						  (integer->char 0)))))
		    (slot-getset type type 0 pointer read-only def-print)
		    (close-port code-port)
		    (close-port extern-port)))))

;;; Slot access functions for a structure are created by the following
;;; function.

(define (SLOT-GETSET type preamble offset base-type read-only def-print)
    
    (define (EMIT-PROCS type name offset)
	    (let ((index (if (isa-array? type) '(i) '())))
		 (def-print
		     `(define (,(uis preamble "-" name) x ,@index)
			      (,(to-get-type type)
			       (,(to-check-type base-type) x)
			       ,offset
			       ,@index)))
		 (unless read-only
			 (def-print
			     `(define (,(uis preamble "-" name "!") x
				       ,@index y)
				      (,(to-set!-type type)
				       (,(to-check-type base-type) x)
				       ,offset
				       ,@index
				       y))))))
    
    (let loop ((slots (uors-slots type)) (offset offset))
	 (if slots
	     (let ((slot-type (caar slots))
		   (slot-name (cadar slots)))
		  (cond ((or (isa-union? slot-type) (isa-struct? slot-type))
			 (slot-getset slot-type
			     (uis preamble "-" slot-name)
			     offset base-type read-only def-print))
			(else (emit-procs slot-type slot-name offset)))
		  (loop (cdr slots)
			(if (isa-union? type)
			    offset
			    (+ offset (size-of slot-type))))))))