;preproc.scm
;Macro preprocessor for SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994

;pretty-print (not needed --- so write is used for
;dialects that don't have it)

(define pp
  (case *dialect*
    ((chez) pretty-print)
    ((scm) (if (defined? pretty-print) pretty-print write))
    (else write)))

;property lists

(define *properties* '())

(define get
  (lambda (x p . default)
    (let ((default (if (pair? default) (car default) #f))
	  (c (memq x *properties*)))
      (if (not c) default
	(let ((d (memq p (cadr c))))
	  (if (not d) default
	    (cadr d)))))))

(define put
  (lambda (x p v)
    (let ((c (memq x *properties*)))
      (if (not c)
	  (set! *properties*
	    (cons x (cons (list p v) *properties*)))
	  (let* ((cdr-c (cdr c))
		 (cadr-c (car cdr-c))
		 (d (memq p cadr-c)))
	    (if (not d)
		(set-car! cdr-c (cons p (cons v cadr-c)))
		(set-car! (cdr d) v)))))))

;macros

(define defmacro/f
  (lambda (keyword transformer)
    (put keyword 'macro transformer)))

(define macro?
  (lambda (m) (get m 'macro)))

(define macro-expand*
  ;;expand thoroughly, not just topmost expression
  (lambda (e)
    (if (not (pair? e)) e
      (let* ((a (car e)) (c (macro? a)))
	(cond (c (macro-expand* (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)
			 (map macro-expand* (cddr e)))))
	      (else (map macro-expand* e)))))))

(define gentemp
  (let ((n -1))
    (lambda ()
      ;;generates an allegedly new symbol.  This is a
      ;;gross hack since there is no standardized way
      ;;of getting uninterned symbols
      (set! n (+ n 1))
      (string->symbol (string-append "%:g" (number->string n) "%")))))

;modules

(define module:determine-locals
  (lambda (e m pfx)
    (if (and (pair? e) (eq? (car e) 'local))
	(for-each
	  (lambda (x)
	    (if (not (get m x))
		(put m x
		  (string->symbol
		    (string-append pfx
		      (symbol->string x))))))
	  (cdr e)))))

(define module:translate
  (lambda (e m)
    (let ((e (macro-expand* e)))
      (if (not m) e
	(let loop ((e e))
	  (cond ((pair? e)
		 (let ((a (car e)))
		   (if (eq? a 'global$) (cadr e)
		     (cons (loop a) (loop (cdr e))))))
		((symbol? e) (get m e e))
		(else e)))))))

(defmacro/f 'module
  (lambda (m) `#f))

(defmacro/f 'extern
  (lambda z `#f))

(defmacro/f 'local
  (lambda z `#f))

(define module:file-determine-locals
  (lambda (f)
    (call-with-input-file f
      (lambda (inp)
	(let ((x (read inp)))
	  (if (not (and (pair? x) (eq? (car x) 'module))) #f
            ;;else do some preprocessing
	    (let* ((m (cadr x))
		   (pfx (symbol->string m)))
	      (let loop ()
		(let ((x (read inp)))
		  (if (not (eof-object? x))
		      (begin
			(module:determine-locals
			  x m pfx)
			(loop)))))
	      #t)))))))

(define module:translate-file-to-port
  (lambda (f outp)
    ;;(write `(set! *load-pathname* ,f) outp)
    (call-with-input-file f
      (lambda (inp)
	(let* ((x (read inp))
	       (m (and (pair? x) (eq? (car x) 'module)
		    (cadr x)))
	       (y (module:translate x m)))
	  (if y (begin (pp y outp) (newline outp)))
	  (let loop ()
	    (let ((x (read inp)))
	      (if (not (eof-object? x))
		  (let ((y (module:translate x m)))
		    (if y (begin (pp y outp) (newline outp)))
		    (loop))))))))))

;;some macros

;fluid-let

(defmacro/f 'fluid-let
  (lambda (let-pairs . body)
    (let ((x-s (map car let-pairs))
    	  (i-s (map cadr let-pairs))
    	  (old-x-s (map (lambda (p) (gentemp)) let-pairs)))
      `(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s)
         ,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s)
         (let ((%temp% (begin ,@body)))
    	   ,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s)
    	   %temp%)))))

;defenum

(defmacro/f 'defenum
  (lambda z
    (let loop ((z z) (n 0) (r '()))
      (if (null? z) `(begin ,@r)
          (loop (cdr z) (+ n 1)
	    (cons `(define ,(car z) (integer->char ,n)) r))))))

;defrecord

(defmacro/f 'defrecord
  (lambda (name . fields)
    (let loop ((fields fields) (i 0) (r '()))
      (if (null? fields)
	  `(begin (define ,name (lambda () (make-vector ,i)))
		  ,@r)
	  (loop (cdr fields) (+ i 1)
	    (cons `(define ,(car fields) ,i) r))))))

;of

(defmacro/f 'of
  (lambda (r i . z)
  (cond ((null? z) `(vector-ref ,r ,i))
	((and (eq? i '/) (= (length z) 1))
	 `(string-ref ,r ,(car z)))
	(else `(of (vector-ref ,r ,i) ,@z)))))

;setf

(defmacro/f 'setf
  (lambda (l r)
  (if (symbol? l) `(set! ,l ,r)
    (let ((a (car l)))
      `(,(cond ((eq? a 'list-ref) 'list-set!)
	       ((eq? a 'string-ref) 'string-set!)
	       ((eq? a 'vector-ref) 'vector-set!)
	       ((eq? a 'of) 'the-setter-for-of)
	       (else (error 'setf a)))
	,@(cdr l) ,r)))))

;the-setter-for-of

(defmacro/f 'the-setter-for-of
  (lambda (r i j . z)
  (cond ((null? z) `(vector-set! ,r ,i ,j))
	((and (eq? i '/) (= (length z) 1))
	 `(string-set! ,r ,j ,(car z)))
	(else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z)))))

;extract-if(-not)

(defmacro/f 'extract-if
  (lambda (dialects . body)
    (if (memq *dialect* dialects)
	(if (= (length body) 1) (car body)
	  `(begin ,@body))
	`#f)))

(defmacro/f 'extract-if-not
  (lambda (dialects . body)
    (if (not (memq *dialect* dialects))
	(if (= (length body) 1) (car body)
	  `(begin ,@body))
	`#f)))

;function

(defmacro/f 'function
  (lambda (x)
    `,x))

(defmacro/f 'funcall
  (lambda (f . args)
    `(,f ,@args)))

;(load (string-append *lib-vicinity* "debug.scm"))
;(trace module:translate-file-to-port)
;(trace module:file-determine-locals)
;(trace module:determine-locals)
;(trace module:translate)
;(trace macro-expand*)