  Copyright ( c ) 1993 - 1999 by   .   See file COPYING .


;   This is a backquote-like macro for building nodes.
;
    One goal is to produce code that is as efficient as possible .
;
; (LET-NODES (<spec1> ... <specN>) . <body>)
;
; <spec> ::= (<ident> <real-call>) |                            ; call node
;            (<ident> (<var1> ... <varN>) <call>) |             ; lambda node
;            (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node
;
  < var >   : : = # f |              Ignored variable position
;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
;            '<ident> |       Evaluate <ident> to get the variable
;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
;
; <last-vars> ::= <ident>
;
; <call> ::= <ident> | <real-call>
;
  < real - call > : : = ( < primop - id > < exits > . < arg - list > )
;
; <arg-list> ::= (<arg1> ... <argN>) | (<arg1> ... <argN> . <last-args>)
;
; <last-args> ::= <ident>
;
; <arg>  ::= 'foo        literal node containing the value of foo, no rep
;            '(foo rep)     "     "       "       "    "   "   " , using rep
;            (* foo)     reference to foo (which evaluates to a variable)
;            (! foo)     foo evaluates to a node
;            foo         short for (! foo) when foo is an atom
;            #f          put nothing here
             ( < primop - id > . < args > )    a nested call
;--------------------------------------
;
; Example:
;
   ( let - nodes ( ( c1 ( l1 1 cont ) )
               ( l1 ( ( j type / pointer ) ) ( proc 2 l2 l3 . rest ) )
;              (l2 () ((jump cont (* j)) '(true-value type/boolean)))
;              (l3 () ((jump cont (* j)) '(false-value type/boolean))))
;    (replace-body node c1))
;
;  ==>
;
;  (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER)))
     ( LET ( ( C1 ( CREATE - CALL - NODE ' 2 1 ) )
;          (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2))
           ( L1 ( CREATE - LAMBDA - NODE ' C ' CONT ( FLIST1 J ' ( ) ) ) )
           ( C.1224 ( CREATE - CALL - NODE ' 4 0 ) )
           ( L2 ( CREATE - LAMBDA - NODE ' C ' CONT ' ( ) ) )
;          (C.1223 (CREATE-CALL-NODE '4 0))
;          (L3 (CREATE-LAMBDA-NODE 'C 'CONT '())))
;      (ATTACH 0 C1 L1)
;      (ATTACH 1 C1 CONT)
;      (ATTACH 0 C.1225 PROC)
       ( ATTACH - CALL - ARGS C.1225 (  ( LIST L2 L3 ) REST ) )
;      (ATTACH-BODY L1 C.1225)
;      (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
       ( ATTACH - THREE - CALL - ARGS C.1224
;                              (CREATE-JUMP-MARKER CONT)
;                              (CREATE-REFERENCE-NODE J)
;                              (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN))
       ( ATTACH - BODY L2 C.1224 )
;      (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
;      (ATTACH-THREE-CALL-ARGS C.1223
;                              (CREATE-JUMP-MARKER CONT)
;                              (CREATE-REFERENCE-NODE J)
;                              (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN))
;      (ATTACH-BODY L3 C.1223)
;      (REPLACE-BODY NODE C1)))
; 

(define (expand-let-nodes form rename compare)
  (destructure (((#f specs . body) form))
    (receive (vars nodes code)
	(parse-node-specs specs rename compare)
      `(,(rename 'let) ,vars
         (,(rename 'let) ,nodes
	    ,@code
	    ,@body)))))

(define (test form)
  (destructure (((#f specs . body) form))
    (receive (vars nodes code)
	(parse-node-specs specs identity eq?)
      `(let ,vars
	 (let ,nodes
	    ,@code
	    ,@body)))))

  Parse the specs , returning a list of variable specs , a list of node specs ,
; and a list of construction forms.  An input spec is either a call or a
; lambda, each is parsed by an appropriate procedure.

(define (parse-node-specs specs r c)
  (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
    (if (null? specs)
        (values vars nodes codes)
        (destructure ((((name . spec) . rest) specs))
          (cond ((null? (cdr spec))
                 (receive (node code)
		     (construct-call name (car spec) r c)
                   (loop rest vars
                         `((,name ,node) . ,nodes) (append code codes))))
                ((= 2 (length spec))
                 (receive (vs node new-spec call)
		     (construct-lambda (car spec) (cadr spec) r c)
                   (loop (if new-spec (cons new-spec rest) rest)
                         (append vs vars)
                         `((,name ,node) . ,nodes)
                         (if call 
                             `((attach-body ,name ,call) . ,codes)
                             codes))))
                (else
                 (error "illegal spec in LET-NODES ~S" (cons name spec))))))))

; The names of the call-arg relation procedures, indexed by the number of
; arguments handled.

(define call-attach-names
  '#(#f
     #f
     attach-two-call-args
     attach-three-call-args
     attach-four-call-args
     attach-five-call-args))

; Return the node spec and construction forms for a call.  This dispatches
; on whether the argument list is proper or not.
;
; <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
;                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
;                 ((JUMP l-node value) <arg1> ... <argN>)
;                 ((JUMP l-node value) <arg1> ... <argN> . <last-args>)

(define (construct-call name specs r c)
  (destructure (((proc . args) specs))
    (really-construct-call name proc (car args) '() (cdr args) r c)))

(define (construct-nested-call specs r c)
  (destructure (((primop-id . args) specs))
    (let ((name (r 'call)))
      (receive (node code)
	  (really-construct-call name primop-id 0 '() args r c)
	`(,(r 'let) ((,name ,node)) ,@code ,name)))))
		    
(define (really-construct-call name primop-id exits extra args r c)
  (receive (arg-count arg-code)
      (parse-call-args name extra args r c)
    (let ((primop-code (get-primop-code primop-id r)))
      (values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits)
	      arg-code))))

(define (get-primop-code id r)
  (cond ((name->enumerand id primop)
	 => (lambda (n)
	      `(,(r 'get-primop) ,n)))
	(else
	 `(,(r 'lookup-primop) ',id))))

; NAME     = the call node which gets the arguments
; EXTRA    = initial, already expanded arguments
; ARGS     = unexpanded arguments
; LAST-ARG = an atom whose value is added to the end of the arguments
; Returns ARG-COUNT-CODE and ARG-CODE

(define (parse-call-args name extra args r c)
  (receive (args last-arg)
      (decouple-improper-list args)
    (let* ((args (append extra (map (lambda (a) (construct-node a r c)) args)))
	   (count (length args)))
      (if (not (null? last-arg))
	  (values `(,(r '+) ,count (,(r 'length) ,last-arg))
		  `((,(r 'attach-call-args)
		     ,name
		     ,(if (null? args)
			  last-arg
			  `(,(r 'append) (,(r 'list) . ,args) ,last-arg)))))
	  (values count
		  (cond ((= count 0)
			 '())
			((and (= count 1) (car args))
			 `((,(r 'attach) ,name 0 ,(car args))))
			((and (< count 6)
			      (every? identity args))
			 `((,(r (vector-ref call-attach-names count))
			    ,name
			    ,@args)))
			(else
			 `((,(r 'attach-call-args) ,name (list . ,args))))))))))

; Return proper part of the list and its last-cdr separately.

(define (decouple-improper-list list)
  (do ((list list (cdr list))
       (res '() (cons (car list) res)))
      ((atom? list)
       (values (reverse! res) list))))

  Dispatch on the type of the SPEC and return the appropriate code .
;
; <arg>  ::= 'foo         literal node containing the value of foo, no rep
;            '(foo rep)   literal node containing the value of foo
;            (* foo)      reference to foo (which evaluates to a variable)
;            (! foo)      foo evaluates to a node
;            name         short for (! name) when foo is an atom

(define (construct-node spec r c)
  (cond ((atom? spec) spec)
        (else
         (destructure (((key data) spec))
           (case key
             ((*)     `(,(r 'make-reference-node) ,data))
             ((quote) (if (pair? data)
                          `(,(r 'make-literal-node) . ,data)
                          `(,(r 'make-literal-node) ,data type/unknown)))
             ((!)     data)
             (else
	      (construct-nested-call spec r c)))))))

  Parse a lambda spec .   This returns a list of variable specs , code to
; construct the lambda node, a spec for the body if necessary, and
; the code needed to put it all together.

(define (construct-lambda vars call r c)
  (receive (vars node)
           (construct-vars vars r c)
    (cond ((null? call)
           (values vars node #f #f))
          ((atom? call)
           (values vars node #f call))
          (else
           (let ((sym (r (generate-symbol 'c))))
             (values vars node `(,sym ,call) sym))))))

; Returns the code needed to construct the variables and the code to make
; the lambda node that binds the variables.
;
  < var >   : : = # f |              Ignored variable position
;            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
;            '<ident> |       Evaluate <ident> to get the variable
;            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)

(define (construct-vars vars r c)
  (let loop ((vs vars) (vlist '()) (code '()))
    (cond ((atom? vs)
           (let ((vars (if (null? vs)
			   `(,(r 'list) . ,(reverse! vlist))
			   `(,(r 'append) (,(r 'list) . ,(reverse! vlist))
					  ,vs))))
             (values code `(,(r 'make-lambda-node) 'c 'cont ,vars))))
          (else
           (let ((spec (car vs))
                 (rest (cdr vs)))
             (cond ((null? spec)
                    (loop rest (cons #f vlist) code))
                   ((atom? spec)
                    (loop rest (cons spec vlist)
                          `((,spec (,(r 'copy-variable) ,spec)) . ,code)))
                   ((c (car spec) 'quote)
                    (loop rest (cons (cadr spec) vlist) code))
                   (else
                    (loop rest (cons (car spec) vlist)
                          `((,(car spec)
                             (,(r 'make-variable) ',(car spec) ,(cadr spec)))
                            . ,code)))))))))

;------------------------------------------------------------------------------
; GENSYM utility

(define *generate-symbol-index* 0)

(define (generate-symbol sym)
  (let ((i *generate-symbol-index*))
    (set! *generate-symbol-index* (+ i 1))
    (concatenate-symbol sym "." i)))


   This is a backquote-like macro for building nodes.


 (LET-NODES (<spec1> ... <specN>) . <body>)

 <spec> ::= (<ident> <real-call>) |                            ; call node
            (<ident> (<var1> ... <varN>) <call>) |             ; lambda node
            (<ident> (<var1> ... <varN> . <last-vars>) <call>) ; lambda node

            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
            '<ident> |       Evaluate <ident> to get the variable
            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)

 <last-vars> ::= <ident>

 <call> ::= <ident> | <real-call>


 <arg-list> ::= (<arg1> ... <argN>) | (<arg1> ... <argN> . <last-args>)

 <last-args> ::= <ident>

 <arg>  ::= 'foo        literal node containing the value of foo, no rep
            '(foo rep)     "     "       "       "    "   "   " , using rep
            (* foo)     reference to foo (which evaluates to a variable)
            (! foo)     foo evaluates to a node
            foo         short for (! foo) when foo is an atom
            #f          put nothing here
--------------------------------------

 Example:

              (l2 () ((jump cont (* j)) '(true-value type/boolean)))
              (l3 () ((jump cont (* j)) '(false-value type/boolean))))
    (replace-body node c1))

  ==>

  (LET ((J (CREATE-VARIABLE 'J TYPE/POINTER)))
          (C.1225 (CREATE-CALL-NODE (+ '3 (LENGTH REST)) '2))
          (C.1223 (CREATE-CALL-NODE '4 0))
          (L3 (CREATE-LAMBDA-NODE 'C 'CONT '())))
      (ATTACH 0 C1 L1)
      (ATTACH 1 C1 CONT)
      (ATTACH 0 C.1225 PROC)
      (ATTACH-BODY L1 C.1225)
      (ATTACH 0 C.1224 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
                              (CREATE-JUMP-MARKER CONT)
                              (CREATE-REFERENCE-NODE J)
                              (CREATE-LITERAL-NODE TRUE-VALUE TYPE/BOOLEAN))
      (ATTACH 0 C.1223 (CREATE-PRIMOP-NODE PRIMOP/JUMP))
      (ATTACH-THREE-CALL-ARGS C.1223
                              (CREATE-JUMP-MARKER CONT)
                              (CREATE-REFERENCE-NODE J)
                              (CREATE-LITERAL-NODE FALSE-VALUE TYPE/BOOLEAN))
      (ATTACH-BODY L3 C.1223)
      (REPLACE-BODY NODE C1)))
 
 and a list of construction forms.  An input spec is either a call or a
 lambda, each is parsed by an appropriate procedure.
 The names of the call-arg relation procedures, indexed by the number of
 arguments handled.
 Return the node spec and construction forms for a call.  This dispatches
 on whether the argument list is proper or not.

 <real-call> ::= (<arg0> <exits> <arg1> ... <argN>) |
                 (<arg0> <exits> <arg1> ... <argN> . <last-args>))
                 ((JUMP l-node value) <arg1> ... <argN>)
                 ((JUMP l-node value) <arg1> ... <argN> . <last-args>)
 NAME     = the call node which gets the arguments
 EXTRA    = initial, already expanded arguments
 ARGS     = unexpanded arguments
 LAST-ARG = an atom whose value is added to the end of the arguments
 Returns ARG-COUNT-CODE and ARG-CODE
 Return proper part of the list and its last-cdr separately.

 <arg>  ::= 'foo         literal node containing the value of foo, no rep
            '(foo rep)   literal node containing the value of foo
            (* foo)      reference to foo (which evaluates to a variable)
            (! foo)      foo evaluates to a node
            name         short for (! name) when foo is an atom
 construct the lambda node, a spec for the body if necessary, and
 the code needed to put it all together.
 Returns the code needed to construct the variables and the code to make
 the lambda node that binds the variables.

            <ident> |        Evaluate <ident> and copy it, rebinding <ident>
            '<ident> |       Evaluate <ident> to get the variable
            (<ident> <rep>)  (MAKE-VARIABLE <ident> <rep>)
------------------------------------------------------------------------------
 GENSYM utility
  Copyright ( c ) 1993 - 1999 by   .   See file COPYING .


    One goal is to produce code that is as efficient as possible .
  < var >   : : = # f |              Ignored variable position
  < real - call > : : = ( < primop - id > < exits > . < arg - list > )
             ( < primop - id > . < args > )    a nested call
   ( let - nodes ( ( c1 ( l1 1 cont ) )
               ( l1 ( ( j type / pointer ) ) ( proc 2 l2 l3 . rest ) )
     ( LET ( ( C1 ( CREATE - CALL - NODE ' 2 1 ) )
           ( L1 ( CREATE - LAMBDA - NODE ' C ' CONT ( FLIST1 J ' ( ) ) ) )
           ( C.1224 ( CREATE - CALL - NODE ' 4 0 ) )
           ( L2 ( CREATE - LAMBDA - NODE ' C ' CONT ' ( ) ) )
       ( ATTACH - CALL - ARGS C.1225 (  ( LIST L2 L3 ) REST ) )
       ( ATTACH - THREE - CALL - ARGS C.1224
       ( ATTACH - BODY L2 C.1224 )

(define (expand-let-nodes form rename compare)
  (destructure (((#f specs . body) form))
    (receive (vars nodes code)
	(parse-node-specs specs rename compare)
      `(,(rename 'let) ,vars
         (,(rename 'let) ,nodes
	    ,@code
	    ,@body)))))

(define (test form)
  (destructure (((#f specs . body) form))
    (receive (vars nodes code)
	(parse-node-specs specs identity eq?)
      `(let ,vars
	 (let ,nodes
	    ,@code
	    ,@body)))))

  Parse the specs , returning a list of variable specs , a list of node specs ,

(define (parse-node-specs specs r c)
  (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '()))
    (if (null? specs)
        (values vars nodes codes)
        (destructure ((((name . spec) . rest) specs))
          (cond ((null? (cdr spec))
                 (receive (node code)
		     (construct-call name (car spec) r c)
                   (loop rest vars
                         `((,name ,node) . ,nodes) (append code codes))))
                ((= 2 (length spec))
                 (receive (vs node new-spec call)
		     (construct-lambda (car spec) (cadr spec) r c)
                   (loop (if new-spec (cons new-spec rest) rest)
                         (append vs vars)
                         `((,name ,node) . ,nodes)
                         (if call 
                             `((attach-body ,name ,call) . ,codes)
                             codes))))
                (else
                 (error "illegal spec in LET-NODES ~S" (cons name spec))))))))


(define call-attach-names
  '#(#f
     #f
     attach-two-call-args
     attach-three-call-args
     attach-four-call-args
     attach-five-call-args))


(define (construct-call name specs r c)
  (destructure (((proc . args) specs))
    (really-construct-call name proc (car args) '() (cdr args) r c)))

(define (construct-nested-call specs r c)
  (destructure (((primop-id . args) specs))
    (let ((name (r 'call)))
      (receive (node code)
	  (really-construct-call name primop-id 0 '() args r c)
	`(,(r 'let) ((,name ,node)) ,@code ,name)))))
		    
(define (really-construct-call name primop-id exits extra args r c)
  (receive (arg-count arg-code)
      (parse-call-args name extra args r c)
    (let ((primop-code (get-primop-code primop-id r)))
      (values `(,(r 'make-call-node) ,primop-code ,arg-count ,exits)
	      arg-code))))

(define (get-primop-code id r)
  (cond ((name->enumerand id primop)
	 => (lambda (n)
	      `(,(r 'get-primop) ,n)))
	(else
	 `(,(r 'lookup-primop) ',id))))


(define (parse-call-args name extra args r c)
  (receive (args last-arg)
      (decouple-improper-list args)
    (let* ((args (append extra (map (lambda (a) (construct-node a r c)) args)))
	   (count (length args)))
      (if (not (null? last-arg))
	  (values `(,(r '+) ,count (,(r 'length) ,last-arg))
		  `((,(r 'attach-call-args)
		     ,name
		     ,(if (null? args)
			  last-arg
			  `(,(r 'append) (,(r 'list) . ,args) ,last-arg)))))
	  (values count
		  (cond ((= count 0)
			 '())
			((and (= count 1) (car args))
			 `((,(r 'attach) ,name 0 ,(car args))))
			((and (< count 6)
			      (every? identity args))
			 `((,(r (vector-ref call-attach-names count))
			    ,name
			    ,@args)))
			(else
			 `((,(r 'attach-call-args) ,name (list . ,args))))))))))


(define (decouple-improper-list list)
  (do ((list list (cdr list))
       (res '() (cons (car list) res)))
      ((atom? list)
       (values (reverse! res) list))))

  Dispatch on the type of the SPEC and return the appropriate code .

(define (construct-node spec r c)
  (cond ((atom? spec) spec)
        (else
         (destructure (((key data) spec))
           (case key
             ((*)     `(,(r 'make-reference-node) ,data))
             ((quote) (if (pair? data)
                          `(,(r 'make-literal-node) . ,data)
                          `(,(r 'make-literal-node) ,data type/unknown)))
             ((!)     data)
             (else
	      (construct-nested-call spec r c)))))))

  Parse a lambda spec .   This returns a list of variable specs , code to

(define (construct-lambda vars call r c)
  (receive (vars node)
           (construct-vars vars r c)
    (cond ((null? call)
           (values vars node #f #f))
          ((atom? call)
           (values vars node #f call))
          (else
           (let ((sym (r (generate-symbol 'c))))
             (values vars node `(,sym ,call) sym))))))

  < var >   : : = # f |              Ignored variable position

(define (construct-vars vars r c)
  (let loop ((vs vars) (vlist '()) (code '()))
    (cond ((atom? vs)
           (let ((vars (if (null? vs)
			   `(,(r 'list) . ,(reverse! vlist))
			   `(,(r 'append) (,(r 'list) . ,(reverse! vlist))
					  ,vs))))
             (values code `(,(r 'make-lambda-node) 'c 'cont ,vars))))
          (else
           (let ((spec (car vs))
                 (rest (cdr vs)))
             (cond ((null? spec)
                    (loop rest (cons #f vlist) code))
                   ((atom? spec)
                    (loop rest (cons spec vlist)
                          `((,spec (,(r 'copy-variable) ,spec)) . ,code)))
                   ((c (car spec) 'quote)
                    (loop rest (cons (cadr spec) vlist) code))
                   (else
                    (loop rest (cons (car spec) vlist)
                          `((,(car spec)
                             (,(r 'make-variable) ',(car spec) ,(cadr spec)))
                            . ,code)))))))))


(define *generate-symbol-index* 0)

(define (generate-symbol sym)
  (let ((i *generate-symbol-index*))
    (set! *generate-symbol-index* (+ i 1))
    (concatenate-symbol sym "." i)))

