;preproc.lsp
;Preprocessor to allow first-class procedures in CL
;(c) Dorai Sitaram, Nov. 1992

(setq *print-case* :downcase)

(defun print/d (x &rest p)
  (apply 'pprint x p)
  (apply 'terpri p))

;make all identifiers referring to functions also have
;their `symbol-value' be that function

(do-all-symbols (x)
  (cond ((boundp x) 'void)
	((macro-function x) 'void)
	((special-form-p x) 'void)
	((fboundp x)
	 (setf (symbol-value x) (symbol-function x)))))

;scm/defun defines functions like above

(defmacro scm/defun (name vv &rest body)
  `(progn
     (defun ,name ,vv ,@body)
     (setf ,name (symbol-function ',name))
     ;;debug
     ;;(trace ,name)
     ;;enddebug
     ))

;named-let

(defmacro named-let (n vv &rest b)
  `(labels ((,n ,(mapcar #'car vv) ,@b))
     (,n ,@(mapcar #'cadr vv))))

;scheme macros

(scm/defun scm/defmacro/f (m f)
  (setf (get m 'macro) f))

(defmacro scm/defmacro (m vv &rest b)
  `(scm/defmacro/f ',m (function (lambda ,vv ,@b))))

(scm/defun scm/macro-p (m)
  (and (symbolp m) (get m 'macro)))

;N.B.: in CL, symbolp is t for nil and t; consp is t for
;closures in some implementations; and functionp is t for
;symbols with symbol-functions

(scm/defun scm/macro-expand (e &optional (n -1))
  (loop
    (cond ((= n 0) (return e))
	  ((functionp e) (return e))
	  ((not (consp e)) (return e))
	  (t (let ((a (car e)))
	       (if (not (symbolp a)) (return e)
		 (let ((m (scm/macro-p a)))
		   (if (not m) (return e)
		     (progn
		       (setq e (apply m (cdr e)))
		       (setq n (- n 1)))))))))))

(scm/defun scm/macroexpand* (e)
  ;;expand thoroughly, not just topmost expression
  (if (not (consp e)) e
    (let* ((a (car e)) (c (scm/macro-p a)))
      (cond (c (scm/macroexpand* (apply c (cdr e))))
	    ((eq a 'quote) e)
	    ((eq a 'lambda)
	     ;;so as not to trip on (... . z) style arguments
	     (cons a (cons (cadr e)
		       (mapcar scm/macroexpand* (cddr e)))))
	    (t (mapcar scm/macroexpand* e))))))

;name clashes between Scheme and CL

(do ((s '(
	  lambda scm/lambda
	  let scm/let
	  let* scm/let*
	  loop loop-scheme
	  )
	(cddr s)))
    ((null s))
    (setf (get 'scm/clash-symbols (car s)) (cadr s)))

;taking care of such name clashes

(scm/defun scm/no-clash (e)
  ;prevent name clashes between Scheme and CL
  (cond	((null e) nil)
	((eq e t) t)
	((symbolp e) (get 'scm/clash-symbols e e))
	((consp e)
	 (let ((a (car e)))
	   (if (eq a 'quote) e
	     (if (and (functionp e) (not (eq a 'lambda)))
		 e
		 (cons (scm/no-clash a)
		   (scm/no-clash (cdr e)))))))
	(t e)))

(scm/defun scm/lambda-rest-args (xx)
  ;;change the `. z' format of Scheme lambda to the
  ;;`&rest z' format of CL lambda
  (let ((yy '()))
    (loop
      (cond ((null xx) (return))
	    ((symbolp xx)
	     (setq yy (cons xx (cons '&rest yy))) (return))
	    ((consp xx)
	     (setq yy (cons (car xx) yy))
	     (setq xx (cdr xx)))
	    (t (error "scm/lambda-rest-args"))))
    (nreverse yy)))

;some macros

(scm/defmacro scm/lambda (parms &rest body)
  `(function
     (lambda ,(scm/lambda-rest-args parms) ,@body)))

(scm/defmacro define (x v)
  `(progn (setq ,x ,v)
     (if (and (functionp ,x) (not (symbolp ,x)))
	 (setf (symbol-function ',x) ,x))
     ;;(trace ,x) ;debug
     ))

(scm/defmacro letrec (pp &rest b)
  `(let ,(mapcar #'(lambda (p) `(,(car p) 'void)) pp)
     ,@(mapcar #'(lambda (p) `(setq ,(car p) ,(cadr p))) pp)
     ,@b))

(scm/defmacro scm/tail-recur (n let-pairs &rest b)
  (let* ((x-s (mapcar #'car let-pairs))
	 (y-s (mapcar #'(lambda (x) (gentemp)) x-s))
	 (tag (gentemp)))
    `(let ,let-pairs
       (flet ((,n ,y-s
		  ,@(mapcar #'(lambda (x y) `(setq ,x ,y))
		      x-s y-s)
		  (throw ',tag 'void)))
       (loop
	 (catch ',tag (return (progn ,@b))))))))

(scm/defmacro scm/recur (name let-pairs &rest body)
  `(letrec ((,name (scm/lambda ,(mapcar #'car let-pairs)
		     ,@body)))
     (funcall ,name ,@(mapcar #'cadr let-pairs))))

(scm/defmacro scm/let (a &rest b)
  ;;named let with name starting `loop...' is considered
  ;;to be iterative and is transformed to CL loop
  (cond ((and a (not (symbolp a))) `(let ,a ,@b))
	((let ((s (symbol-name a)))
	   (and (>= (length s) 4)
		(string-equal (subseq s 0 4) "loop")))
	 `(scm/tail-recur ,a ,@b))
	(t `(scm/recur ,a ,@b))))

(scm/defmacro scm/let* (let-pairs &rest body)
  (if (null let-pairs) `(progn ,@body)
    `(let ((,(caar let-pairs) ,(cadar let-pairs)))
       (scm/let* ,(cdr let-pairs) ,@body))))

(scm/defmacro fluid-let (let-pairs &rest body)
  `(let ,let-pairs
     (declare (special ,@(mapcar #'car let-pairs)))
     ,@body))

;modules

(scm/defun scm/module/determine-locals (e m pfx)
  (let ((e (scm/no-clash e)))
    (if (and (consp e) (eq (car e) 'local))
	(mapc #'(lambda (x)
		  (if (not (get m x))
		      (setf (get m x)
			(intern
			  (concatenate 'string pfx
			    (symbol-name x))))))
		   (cdr e)))))

(scm/defun scm/module/translate (e m)
  (let ((e (scm/macroexpand* (scm/no-clash e))))
    (if (not m) e
      (named-let x-loop ((e e))
	(cond ((consp e)
	       (let ((a (car e)))
		 (if (eq a 'global$) (cadr e)
		   (cons (x-loop a) (x-loop (cdr e))))))
	      ((null e) nil)
	      ((eq e t) t)
	      ((symbolp e) (get m e e))
	      (t e))))))

(scm/defmacro module (m) nil)

(scm/defmacro extern (&rest b) nil)

(scm/defmacro local (&rest b) nil)

(scm/defun scm/module/file-determine-locals (f)
  (with-open-file (inp f :direction :input)
    (let ((x (read inp)))
      (if (not (and (consp x) (eq (car x) 'module))) nil
	;;else do some preprocessing
	(let* ((m (cadr x))
	       (pfx (symbol-name m)))
	  (loop
	    (let ((x (read inp nil :eof-object)))
	      (if (eq x :eof-object) (return)
		(scm/module/determine-locals
		  x m pfx))))
	  t)))))

(scm/defun scm/module/copy-port (inp outp)
  (loop
    (let ((x (read inp nil :eof-object)))
      (if (eq x :eof-object) (return)
	(print/d x outp)))))

(scm/defun scm/module/translate-file-to-port (f outp)
  ;;(print/d `(setq *load-pathname* ,f) outp)
  (with-open-file (inp f :direction :input)
    (let* ((x (read inp))
	   (m (and (consp x) (eq (car x) 'module)
		(cadr x)))
	   (y (scm/module/translate x m)))
      (if y (print/d y outp))
      (loop
	(let ((x (read inp nil :eof-object)))
	  (if (eq x :eof-object) (return)
	    (let ((y (scm/module/translate x m)))
	      (if y (print/d y outp)))))))))

;debug

;(trace scm/no-clash scm/insert-funcalls)