scsh-0.5/opt/expand.scm

; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.


; Front end for Scheme 48 compilation, optimization, or whatever.

; Entry point for debugging or casual use.

(define (expand-form form p)
  (let-fluid $assignments #f
    (lambda ()
      (expand-begin (scan-forms (list form) p #f)
		    (package->environment p)))))


; After processing a package body, we change the types of all
; unassigned top-level variables from (VARIABLE <type>) to <type>.

(define (expand-stuff stuff p)
  (let* ((table (make-table))
	 (env (package->environment p))
	 (new-stuff
	  (let-fluid $assignments (cons p table)
	    (lambda ()
	      (map (lambda (filename+nodes)
		     (let ((filename (car filename+nodes))
			   (nodes (cdr filename+nodes)))
		       (cons filename
				 (let ((env (bind-source-file-name filename env)))
				   (map (lambda (node)
					  (expand node env))
					nodes)))))
		   stuff)))))
    (for-each (lambda (filename+nodes)
		(for-each (lambda (node)
			    (if (define-node? node)
				(maybe-update-known-type node p table)))
			  (cdr filename+nodes)))
	      new-stuff)
    new-stuff))

(set-optimizer! 'expand expand-stuff)

(define (maybe-update-known-type node p table)
  (let ((lhs (cadr (node-form node))))
    (if (not (table-ref table lhs))
	(let ((new-type (reconstruct-type (caddr (node-form node))
					  (package->environment p))))
	  (if (subtype? new-type any-values-type)
	      (package-define! p lhs (if (subtype? new-type value-type)
					 new-type
					 value-type))
	      (warn "ill-typed right-hand side"
		    (schemify node)
		    (type->sexp new-type #t)))))))

(define lambda-node? (node-predicate 'lambda))


; --------------------
; Expand a single form.

(define (expand form env)
  (let ((node (classify form env)))
    (if (already-expanded? node)
	node
	((get-expander (node-operator-id node)) node env))))

(define expanders
  (make-operator-table (lambda (node env)
			 (let ((form (node-form node)))
			   (make-expanded node
					  (cons (car form)
						(map (lambda (arg-exp)
						       (expand arg-exp env))
						     (cdr form))))))))

(define (define-expander name type proc)
  (operator-define! expanders name type proc))

(define (get-expander id)
  (operator-table-ref expanders id))

(define-expander 'literal #f
  (lambda (node env)
    (set-expanded node)))

(define-expander 'name #f
  (lambda (node env)
    (note-reference! node)
    node))

(define-expander 'call #f
  (lambda (node env)
    (let ((exp (node-form node)))
      (let ((proc-node (expand (car exp) env)))
	(note-operator! proc-node)
	(make-expanded node
		       (cons proc-node
			     (map (lambda (arg-exp)
				    (expand arg-exp env))
				  (cdr exp))))))))


; Special operators

(define-expander 'quote syntax-type
  (lambda (node env)
    (set-expanded node)))

(define-expander 'lambda syntax-type
  (lambda (node env)
    (set-fluid! $inferior-lambdas? #t)
    (let-fluid $inferior-lambdas? #f
      (lambda ()
	(let* ((exp (node-form node))
	       (formals (cadr exp)))
	  (with-lexicals (normalize-formals formals) env
	    (lambda (env lexicals)
	      (let ((node (make-expanded node
					 (list (car exp)
					       formals
					       (expand-body (cddr exp) env)))))
		(if (not (fluid $inferior-lambdas?))
		    (node-set! node 'no-inferior-lambdas #t))
		node))))))))

(define with-lexicals
  (let ((operator/name (get-operator 'name)))
    (lambda (vars env proc)
      (let* ((lexicals (map make-lexical vars))
	     (var-nodes (map (lambda (formal lexical)
			       (let ((var-node
				      (make-node operator/name formal)))
				 (node-set! var-node 'lexical lexical)
				 var-node))
			     vars
			     lexicals))
	     (node (proc (bind vars var-nodes env) lexicals)))
	(node-set! node 'var-nodes var-nodes)
	node))))


(define-expander 'letrec syntax-type
  (lambda (node env)
    (set-fluid! $inferior-lambdas? #t)	;foo
    (let* ((exp (node-form node))
	   (specs (cadr exp))
	   (body (cddr exp)))
      (with-lexicals (map car specs) env
	(lambda (env lexicals)
	  (let* ((specs (map (lambda (spec)
			       (list (car spec)
				     (expand (cadr spec) env)))
			     specs))
		 (node (make-expanded node
				      (list (car exp)
					    specs
					    (expand-body body env)))))
	    (if (and (every (lambda (spec)
			      (lambda-node? (cadr spec)))
			    specs)
		     (every (lambda (lexical)
			      (and (= (lexical-assignment-count lexical) 0)
				   (= (lexical-reference-count lexical)
				      (lexical-operator-count lexical))))
			    lexicals))
		(node-set! node 'pure-letrec #t))
	    node))))))

(define $inferior-lambdas? (make-fluid #t))

(define expand-body
  (let ((operator/letrec (get-operator 'letrec syntax-type)))
    (lambda (body env)
      (scan-body body
		 env
		 (lambda (defs exps)	;defs is a list of define nodes
		   (if (null? defs)
		       (expand-begin exps env)
		       (expand (make-node
				   operator/letrec
				   `(letrec ,(map (lambda (def)
						    (cdr (node-form def)))
						  defs)
				      ,@exps))
			       env)))))))

(define expand-begin
  (let ((op (get-operator 'begin syntax-type)))
    (lambda (exp-list env)
      (let ((nodes (map (lambda (exp) (expand exp env))
			exp-list)))
	(if (null? (cdr nodes))
	    (car nodes)
	    (set-expanded (make-node op (cons 'begin nodes))))))))

(define-expander 'set! syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (let ((lhs (classify (cadr exp) env))
	    (rhs (expand (caddr exp) env)))
	(if (name-node? lhs)
	    (begin (if (node-ref lhs 'lexical)
		       (note-assignment! lhs)
		       (note-top-level-assignment! (node-form lhs)))
		   (make-expanded node (list (car exp) lhs rhs)))
	    (expand (syntax-error "invalid assignment" (node-form node))
		    env))))))

(define name-node? (node-predicate 'name 'leaf))

(define (name-node-binding node cenv)
  (or (node-ref node 'binding)
      (lookup cenv (node-form node))))

(define-expander 'define syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      (make-expanded node
		     (list (car form)
			   (cadr form)
			   (expand (caddr form) env))))))

(define-expander 'if syntax-type
  (lambda (node env)
    (let ((exp (node-form node)))
      (make-expanded node
		     (list (car exp)
			   (expand (cadr exp) env)
			   (expand (caddr exp) env)
			   (expand (cadddr exp) env))))))

(define-expander 'primitive-procedure syntax-type
  (lambda (node env)
    (set-expanded node)))


; --------------------
; Expanded nodes

(define (make-expanded node form)
  (set-expanded (make-similar-node node form)))

(define (set-expanded node)
  (node-set! node 'expanded #t)
  node)

(define (already-expanded? node)
  (node-ref node 'expanded))

; --------------------
; Keep track of which defined top-level variables are assigned

(define $assignments (make-fluid #f))

(define (note-top-level-assignment! name)
  (let ((package+table (fluid $assignments)))
    (if package+table
	(if (generated? name)
	    (if (eq? (generated-env name) (car package+table))
		(table-set! (cdr package+table) (generated-symbol name) #t))
	    (table-set! (cdr package+table) name #t)))))


; --------------------
; Lexical information structures record the number of times that a
; variable is used.

(define (make-lexical name)
  (vector 0 0 0))

(define (lexical-accessor j)
  (lambda (lex)
    (vector-ref lex j)))

(define (lexical-incrementator j)
  (lambda (node)
    (let ((v (node-ref node 'lexical)))
      (if v
	  (vector-set! v j (+ (vector-ref v j) 1))))))

(define lexical-reference-count  (lexical-accessor 0))
(define lexical-operator-count   (lexical-accessor 1))
(define lexical-assignment-count (lexical-accessor 2))

(define note-reference!  (lexical-incrementator 0))
(define note-operator!   (lexical-incrementator 1))
(define note-assignment! (lexical-incrementator 2))