;;; Ported from Scheme 48 1.9. See file COPYING for notices and license. ;;; ;;; Port Author: Andrew Whatson ;;; ;;; Original Authors: Richard Kelsey, ;;; ;;; scheme48-1.9.2/ps-compiler/node/let-nodes.scm ;;; ;;; This is a backquote-like macro for building nodes. ;;; ;;; One goal is to produce code that is as efficient as possible. ;;; We aren't quite there yet. ;;; ;;; (LET-NODES ( ... ) . ) ;;; (NEW-CALL . ) ;;; These all create cont lambdas: ;;; (NEW-LAMBDA ( ... ) ) ;;; (NEW-LAMBDA ( ... . ) ) ;;; (NEW-LAMBDA

) ;;; (NEW-LAMBDA ( ... )) ;;; (NEW-LAMBDA ( ... . )) ;;; (NEW-LAMBDA ) ;;; ;;; ::= (

) | ; call node ;;; ( ( ... ) ) | ; cont lambda node ;;; ( ( ... . ) ) ; cont lambda node ;;; ( ) | ; cont lambda node ;;; ;;; ::= #f | Ignored variable position ;;; | Evaluate and copy it, rebinding ;;; ' | Evaluate to get the variable ;;; ( ) (MAKE-VARIABLE ) ;;; ;;; ::= ;;; ;;; ::= | ;;; ;;; ::= ( . ) ;;; ;;; ::= ( ... ) | ( ... . ) ;;; ;;; ::= ;;; ;;; ::= '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 ;;; ( . ) a nested (simple) call ;;;-------------------------------------- ;;; ;;; Example: ;;; ;;; (let-nodes ((call (let 1 l1 . vals)) ;;; (l1 vars lr1)) ;;; call) ;;; ====> ;;; (let ((call (make-call-node (get-primop (enum primop let) (+ 1 (length vals)) 1))) ;;; (l1 (make-lambda-node 'c 'cont (append (list) vars)))) ;;; (attach-call-args call (append (list l1) vals)) ;;; (attach-body l1 lr1) ;;; call) (define-module (ps-compiler node let-nodes) #:use-module (srfi srfi-8) #:use-module (prescheme scheme48) #:use-module (ps-compiler node arch) #:use-module (ps-compiler node node) #:use-module (ps-compiler node node-util) #:use-module (ps-compiler node primop) #:use-module (ps-compiler util util) #:export (let-nodes new-lambda new-call)) (define-syntax let-nodes (lambda (x) (syntax-case x () ((_ (specs ...) body ...) (receive (vars nodes code) (parse-node-specs #'(specs ...)) #`(let #,vars (let #,nodes #,@code body ...))))))) ;; (NEW-LAMBDA ( ... ) ) ;; (NEW-LAMBDA ( ... . ) ) ;; (NEW-LAMBDA ) ;; (NEW-LAMBDA ( ... )) ;; (NEW-LAMBDA ( ... . )) ;; (NEW-LAMBDA ) (define-syntax new-lambda (lambda (x) (syntax-case x () ((_ vars) (receive (vars node) (construct-vars #'vars) #`(let #,vars #,node))) ((_ vars maybe-call) (receive (vars node) (construct-vars #'vars) #`(let #,vars (let ((the-lambda #,node) (the-call maybe-call)) (attach-body the-lambda the-call) the-lambda))))))) (define-syntax new-call (lambda (x) (syntax-case x (the-call) ((_ specs ...) (let ((call-name #'the-call)) (receive (node code) (construct-call call-name #'(specs ...)) #`(let ((#,call-name #,node)) #,@code #,call-name))))))) ;; 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) (let loop ((specs (reverse specs)) (vars '()) (nodes '()) (codes '())) (if (null? specs) (values vars nodes codes) (syntax-case specs () (((name spec) . rest) (receive (node code) (construct-call #'name #'spec) (loop #'rest vars (cons #`(name #,node) nodes) (append code codes)))) (((name vs call) . rest) (receive (vs node new-spec call) (construct-lambda #'vs #'call) (loop (if new-spec (cons new-spec #'rest) #'rest) (append vs vars) (cons #`(name #,node) nodes) (if call (cons #`(attach-body name #,call) codes) codes)))))))) ;; 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. ;; ;; ::= ( ... ) | ;; ( ... . )) (define (construct-call name specs) (syntax-case specs () ((proc arg . args) (really-construct-call name #'proc #'arg '() #'args)))) (define (construct-nested-call specs) (syntax-case specs (call) ((primop-id args ...) (let ((name #'call)) (receive (node code) (really-construct-call name #'primop-id 0 '() #(args ...)) #`(let ((#,name #,node)) #,@code #,name)))))) (define (really-construct-call name primop-id exits extra args) (receive (arg-count arg-code) (parse-call-args name extra args) (let ((primop-code (get-primop-code primop-id))) (values #`(make-call-node #,primop-code #,arg-count #,exits) arg-code)))) (define (get-primop-code id) (cond ((name->enumerand (syntax->datum id) primop-enum) => (lambda (n) #`(get-primop #,n))) (else #`(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) (receive (args last-arg) (decouple-improper-list args) (let* ((args (append extra (map construct-node args))) (count (length args))) (if (not (null? last-arg)) (values #`(+ #,count (length #,last-arg)) #`((attach-call-args #,name #,(if (null? args) last-arg #`(append (list #,@args) #,last-arg))))) (values count (cond ((= count 0) '()) ((and (= count 1) (car args)) #`((attach #,name 0 #,(car args)))) ((and (< count 6) (every? identity args)) #`((#,(vector-ref call-attach-names count) #,name #,@args))) (else #`((attach-call-args #,name (list #,@args)))))))))) ;; Return proper part of the list and its last-cdr separately. (define (decouple-improper-list ls) (let loop ((ls ls) (res '())) (syntax-case ls () ((head . tail) (loop #'tail (cons #'head res))) (last-arg (values (reverse! res) #'last-arg))))) ;; Dispatch on the type of the SPEC and return the appropriate code. ;; ;; ::= '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 ;; #f put nothing here ;; ( . ) a nested (simple) call (define (construct-node spec) (syntax-case spec () ((key data) (case (syntax->datum #'key) ((*) #'(make-reference-node data)) ((quote) (if (pair? #'data) #'(make-literal-node data) #'(make-literal-node data 'type/unknown))) ((!) #'data) (else (construct-nested-call spec)))) (spec #'spec))) ;; 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) (receive (vars node) (construct-vars vars) (syntax-case call () (() (values vars node #f #f)) ((head . tail) (let ((sym (datum->syntax call (generate-symbol 'c)))) (values vars node #`(#,sym (head . tail)) sym))) (call (values vars node #f #'call))))) ;; Returns the code needed to construct the variables and the code to make ;; the lambda node that binds the variables. ;; ;; ::= #f | Ignored variable position ;; | Evaluate and copy it, rebinding ;; ' | Evaluate to get the variable ;; ( ) (MAKE-VARIABLE ) (define (construct-vars vars) (let loop ((vs vars) (vlist '()) (code '())) (syntax-case vs (quote) ((() . rest) (loop #'rest (cons #'#f vlist) code)) (((quote ident) . rest) (loop #'rest (cons #'ident vlist) code)) (((ident rep) . rest) (loop #'rest (cons #'ident vlist) (cons #'(ident (make-variable 'ident rep)) code))) ((ident . rest) (loop #'rest (cons #'ident vlist) (cons #'(ident (copy-variable ident)) code))) (() (values code #`(make-lambda-node 'c 'cont (list #,@(reverse! vlist))))) (vs (values code #`(make-lambda-node 'c 'cont (append (list #,@(reverse! vlist)) vs))))))) ;;------------------------------------------------------------------------------ ;; 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)))