;       -*- Mode:LISP; Package:OBJ; Base:10; Readtable:CL; Syntax: Common-lisp -*-

;; Copyright (C) Gary Drescher 1984, 1985
;; Licensed to and distributed by Lisp Machine, Inc.
;;   See filename "Copyright" for
;; licensing and release information.

(in-package "OBJ")

;;;; Commonlisp codewalker
; Identifies and transforms free variable and function references.
; Ignores flow of control.

(defparameter *bound-vars nil)	; Locally bound variables, lexical & special.
(defparameter *bound-fcns nil)	; Locally bound functions (lexical).
(defparameter *specials nil)	; Locally special variables (from declarations).

(defparameter *free-var-ref-transform nil)
(defparameter *free-var-set-transform nil)
(defparameter *free-fcncall-transform nil)

(defun transform-free-var-ref (sym)
  (iff (null *free-var-ref-transform) sym (funcall *free-var-ref-transform sym)))

(defun transform-free-var-set (sym val)
 (iff (null *free-var-set-transform)
     (list 'setq sym val)
     (funcall *free-var-set-transform sym val)))

(defun transform-free-fcncall (tail? fcn-args)
 (iff (null *free-fcncall-transform)
     fcn-args
   (funcall *free-fcncall-transform tail? fcn-args)))

(defun free-var-ref? (sym)
 (not (memq sym *bound-vars)))

(defun free-fcn-ref? (sym args)
  (and (not (null sym))
       (not (memq sym *bound-fcns))
       ;; Not a funcall/apply/call of a lexically bound fcn-name:
       (not (and (memq sym '(funcall apply call))
		 (or (not (and (consp (car args))
			       (memq (car (car args)) '(quote function))))
		     (not (free-fcn-ref? (cadr (car args)) (cdr args))))))))

(defmacro push-local (sym locals)
  `(push ,sym ,locals))

(defmacro append-local (syms locals)
  `(setf ,locals (append ,syms ,locals)))

;ALWAYS Bind *BOUND-VARS and *SPECIALS around this.
(defun walk-any-dcls (body)
  (mapc #'(lambda (form)
	    (when (and (consp form) (eq (pop form) 'declare))
	      (mapc #'(lambda (dcl)
			(when (and (consp dcl) (eq (pop dcl) 'special))
			  (mapc #'(lambda (sym)
				    (when (symbolp sym)
				      (push sym *specials)))
				dcl)))
		    form)))
	body))

#| progn block catch throw progv let let* flet if go tagbody setq labels the declare
quote return-from macrolet multiple-value-call multiple-value-prog1 unwind-protect

!!! macrolet

!!!(compiler-let ((x (foo y))  (y z)) x y z...)
-> (compiler-let ((x (foo (obl-sym y))) (y [z may or may not be special))
     (obl-sym x) (obl-sym y) [z may or may not be special])
but if z (init-form) is in the compiler-env, it >can't< be lexical;
 whereas if it's in the runtime-env, it >might< be.  different semantics for
 different times.

 presumption of compiletime may get global/obj variables at evaltime, bypassing
  lexical bindings.  this >might< be what's intended tho; would be more 
  consistent.
 presumption of evaltime may get global variables at compiletime, bypassing
  compiletime object-bingings.  this is ok if we document it.
probly presumption of compiletime is better.

|#

(defparameter *obl-walking? nil)

(defun walk-toplevel-form (form &optional *free-var-ref-transform
			                  *free-var-set-transform
					  *free-fcncall-transform
			        &aux (*obl-walking? t))
  (walk-form t form))

(defparameter *walkers
	      '((setq . walk-setq) (quote . walk-quote) (cond . walk-cond)
		(progv . walk-progv) (lambda . walk-lambda) (let . walk-let)
		(let* . walk-let*) (flet . walk-flet) (labels . walk-labels)
		(compiler-let . walk-compiler-let) (declare . walk-quote)
		(return-from . walk-return-from) (go . walk-quote)
		(function . walk-function) (progn . walk-tail) (block . walk-block)
		(catch . walk-notail) (throw . walk-notail) (if . walk-if)
		(and . walk-tail) (or . walk-tail) (multiple-value-call . walk-notail)
		(multiple-value-prog1 . walk-notail) (unwind-protect . walk-notail)
		(eval-when . walk-eval-when)
		#+symbolics (zl:eval-when . walk-eval-when)

		;; Plus some extras (not commonlisp special forms):
		(defun . walk-defun) #+symbolics (zl:defun . walk-defun)
		(multiple-value-bind . walk-mvb)
		(multiple-value-setq . walk-mvsetq)
		(prog . walk-prog) (prog* . walk-prog*)
		(return . walk-tail)
		#+lambda (variable-boundp . walk-quote)
		#+lambda (variable-makunbound . walk-quote)
		#+lambda (variable-location . walk-quote)
		#+symbolics (zl:variable-boundp . walk-quote)
		#+symbolics (zl:variable-makunbound . walk-quote)
		#+symbolics (zl:variable-location . walk-quote)
		))

(defun walk-form (tail? form &optional quote-atoms? &aux walker)
  ;; !!! Should catch errors.
  (cond ((constantp form) form)
	((and (symbolp form) (free-var-ref? form) (not quote-atoms?))
	 (transform-free-var-ref form))
	((symbolp form) form)
	((not (consp form)) form)
	(t (let ((fcn-form (car form))  (arg-forms (cdr form)))
	     (if (and (symbolp fcn-form)
		      (setq walker (cdr (assq fcn-form *walkers))))
		 (walk-special-form tail? form walker)
	         ;; Not special form, try macroexpand:
	         (let ((expansion (macroexpand form)))
		   (iff (not (eq expansion form))
			(walk-form tail? expansion quote-atoms?)
		     ;; If no expansion, try user transformation:
		     (iff (and (symbolp fcn-form)
			       (free-fcn-ref? fcn-form arg-forms))
			  (setq form (transform-free-fcncall tail? form)
				fcn-form (car form)  arg-forms (cdr form)))
		     ;; Then proceed as usual.
		     (cond ((symbolp fcn-form)
			    (iff (special-form-p fcn-form)
				 (iff (setq walker (cdr (assq fcn-form *walkers)))
				      (walk-special-form tail? form walker)
				   (error "~%Non-CommonLisp special form: ~s"
					  fcn-form))
			      (walk-fcncall tail? form)))
			   (t (cons (walk-form nil fcn-form)
				    (walk-forms nil arg-forms)))))))))))

(defun walk-special-form (tail? fcn-args walker)
  (funcall walker tail? fcn-args))

(defun walk-forms (tail? forms &optional quote-atoms?)
  (maplist #'(lambda (forms &aux (form (pop forms)))
	       (walk-form (and tail? (null forms))
			  form quote-atoms?))
	   forms))

(defun walk-setq (tail? form) tail?
  (cond ((null (cddr form)) form)
	((null (cdddr form))
	 (iff (free-var-ref? (cadr form))
	     (transform-free-var-set (cadr form) (walk-form nil (caddr form)))
	     (list 'setq (cadr form) (walk-form nil (caddr form)))))
	(t (cons 'progn
		 (nloop (with f (cdr form))
			(stop-unless (consp f))
			(for sym (pop f))
			(collect
			  (iff (null f)
			      (list 'setq sym)
			      (iff (free-var-ref? sym)
				  (transform-free-var-set sym (walk-form nil (pop f)))
				  (list 'setq sym (walk-form nil (pop f)))))))))))

(defun walk-quote (tail? form) tail?
  form)

(defun walk-the (tail? forms)
  (list* 'the (cadr forms) (walk-forms tail? (cddr forms))))

(defun walk-function (tail? forms) tail?
  (iff (and (symbolp (cadr forms)) (null (cddr forms)))
      forms
      (list* 'function (walk-form nil (cadr forms))
	     (cddr forms))))

(defun walk-tail (tail? forms)
  (cons (car forms) (walk-forms tail? (cdr forms))))

(defun walk-notail (tail? forms) tail?
  (cons (car forms) (walk-forms nil (cdr forms))))

(defun walk-block (tail? forms) tail?
  (list* 'block (cadr forms) (walk-forms tail? (cddr forms))))

(defun walk-fcncall (tail? forms) tail?
  (cons (car forms) (walk-forms nil (cdr forms))))

(defun walk-if (tail? forms)
  (list* 'if (walk-form nil (cadr forms))
	     (walk-form tail? (caddr forms))
	     (walk-forms tail? (cdddr forms))))

(defun walk-cond (tail? forms)
  (cons 'cond (maplist #'(lambda (clauses &aux (clause (pop clauses)))
			   (iff (consp clause)
			       (walk-forms (and tail? (null clauses))
					   clause)
			       (walk-form nil clause)))
		       (cdr forms))))

(defun walk-progv (tail? forms)	; (No dcls allowed in PROGV.)
  (let ((fcn (pop forms)) (vars (pop forms)) (vals (pop forms)))
    fcn
    (list* 'progv vars (walk-form nil vals)
	   (walk-forms tail? forms))))

(defun walk-eval-when (tail? forms)
  (let ((fcn (pop forms)) (sits (pop forms)))
    fcn
    (list* 'eval-when sits (walk-forms tail? forms))))

(defun walk-tagbody (tail? forms)	; (No dcls allowed in TAGBODY.)
  (list* 'tagbody (walk-forms tail? (cdr forms) t)))

(defun walk-prog (tail? forms)
  (walk-let tail? forms t))

(defun walk-prog* (tail? forms)
  (walk-let* tail? forms t))

(defun walk-mvb (tail? forms &aux (*bound-vars *bound-vars) *specials)
  (let ((fcn (pop forms)) (vars (pop forms)) (source (pop forms)))
    fcn
    (walk-any-dcls forms)
    (list* 'multiple-value-bind vars (walk-form nil source)
	   (progn (append-local vars *bound-vars)
		  (walk-forms tail? forms)))))

(defun walk-mvsetq (tail? forms) tail?
  (let ((fcn (pop forms)) (vars (pop forms)) (form (pop forms)))
    fcn
    (list* 'multiple-value-setq vars (walk-form nil form) (walk-forms nil forms))))

(defun walk-defun (tail? forms) tail?
  (let ((fcn (pop forms)) (name (pop forms)) (args (pop forms)))
    (cons fcn (walk-definition name args forms))))

(defun walk-lambda (tail? forms) tail?
  (let ((fcn (pop forms)) (args (pop forms)))
    (walk-definition fcn args forms)))

(defun walk-definition (def args body &aux (*bound-vars *bound-vars) *specials)
  (walk-any-dcls body)
  (list* def (walk-arglist args) (walk-forms t body)))

; This pushes onto *BOUND-VARS, bind that before calling this.
(defun walk-arglist (args)
  (iff (not (consp args))
      args
      (mapcar #'(lambda (arg)
		  (cond ((symbolp arg)
			 (unless (memq arg lambda-list-keywords)
			   (push-local arg *bound-vars))
			 arg)
			((consp arg)
			 (prog1
			   (list* (car arg)	  ;; <var>
				  (walk-form nil (cadr arg)) ;; <init-form>
				  (cddr arg))	       	       ;; ( <svar> )
			   (cond ((symbolp (car arg))	       ;; Var
				  (push-local (car arg) *bound-vars))
				 ((and (consp (car arg));; (( <key> <var> )... )
				       (not (null (cdr (car arg))))
				       (symbolp (cadr (car arg))))
				  (push-local (cadr (car arg))
						       *bound-vars)))
			   (or (null (cddr arg)) (not (symbolp (caddr arg)))
			       (push-local (caddr arg) *bound-vars))))
			(t arg)))
              args)))
				


(defun bind-vars-parallel (var-forms &aux (new-locals *bound-vars))
  (values
    (mapcar #'(lambda (var-form &aux sym)
		(iff (and (symbolp var-form) (not (null var-form)))
		    (setq sym var-form
			  var-form nil)
		    (setq sym (pop var-form)))
		(push-local sym new-locals)
		(list* sym (walk-form nil (car var-form))
		       (cdr var-form)))
	    var-forms)
    new-locals))

(defun walk-let (tail? forms &optional quote-atoms? &aux (*bound-vars *bound-vars) *specials)
  (let ((fcn (pop forms)) (var-forms (pop forms)))
    (walk-any-dcls forms)
    (list* fcn
	   (multiple-value-bind (vforms new-locals)
	       (bind-vars-parallel var-forms)
	     (list* vforms
		    (let ((*bound-vars new-locals))
		      (walk-forms tail? forms quote-atoms?)))))))

(defun bind-vars-sequential (var-forms)
  (mapcar #'(lambda (var-form &aux sym)
	      (iff (and (symbolp var-form) (not (null var-form)))
		  (setq sym var-form
			var-form nil)
		  (setq sym (pop var-form)))
	      (prog1
		(list* sym (walk-form nil (car var-form))
		       (cdr var-form))
		(push-local sym *bound-vars)))
	  var-forms))

(defun walk-let* (tail? forms &optional quote-atoms? &aux (*bound-vars *bound-vars) *specials)
  (let ((fcn (pop forms)) (var-forms (pop forms)))
    (walk-any-dcls forms)
    (list* fcn (bind-vars-sequential var-forms)
	   (walk-forms tail? forms quote-atoms?))))

(defun walk-flet (tail? forms &aux (new-flocals *bound-fcns) (*bound-vars *bound-vars)
			           *specials)
  (let ((fcn (pop forms)) (fcn-forms (pop forms)))
    fcn
    (walk-any-dcls forms)
    (list* 'flet
	   (mapcar #'(lambda (def)
		       (iff (and (consp def) (symbolp (car def)))
			   (push (car def) new-flocals))       
		       (iff (and (consp def) (consp (cdr def)))
			   (walk-definition (car def) (cadr def)
					    (cddr def))
			   def))
		   fcn-forms)
	   (let ((*bound-fcns new-flocals))
	     (walk-forms tail? forms)))))

(defun walk-labels (tail? forms &aux (*bound-fcns *bound-fcns) (*bound-vars *bound-vars)
			             *specials)
  (let ((fcn (pop forms)) (fcn-forms (pop forms)))
    fcn
    (walk-any-dcls forms)
    (mapc #'(lambda (def)
	      (iff (and (consp def) (symbolp (car def)))
		  (push (car def) *bound-fcns)))
	  fcn-forms)
    (list* 'labels
	   (mapcar #'(lambda (def)
		       (iff (and (consp def) (consp (cdr def)))
			   (walk-definition (car def) (cadr def)
					    (cddr def))
			   def))
		   fcn-forms)
	   (walk-forms tail? forms))))

(defun walk-compiler-let (tail? forms)
       ;; (No declarations allowed.)
  (let ((fcn (pop forms)) (var-forms (pop forms)))
    fcn
    (list* 'compiler-let
	   (mapcar #'(lambda (var-form &aux sym)
		       (iff (and (symbolp var-form) (not (null var-form)))
			   (setq sym var-form
				 var-form nil)
			   (setq sym (pop var-form)))
		       (list* sym (walk-form nil (car var-form))
			      (cdr var-form)))
		   var-forms)
	   (walk-forms tail? forms))))

(defun walk-return-from (tail? forms) tail?
  (let ((fcn (pop forms)) (name (pop forms)) (result (pop forms)))
    fcn
    (list* name (walk-form nil result) forms)))