;;; extend-syntax.sc

;;; Copyright (C) 1987 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful noncommercial purpose, and to redistribute
;;; this software is granted subject to the restriction that all copies
;;; made of this software must include this copyright notice in full.
;;; Cadence makes no warranties or representations of any kind, either
;;; express or implied, including but not limited to implied warranties
;;; of merchantability or fitness for any particular purpose.

;;; The basic design of extend-syntax is due to Eugene Kohlbecker.  See
;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
;;; Ph.D.  Dissertation, Indiana University, 1986."  The structure of "with"
;;; pattern/value clauses, the method for compiling extend-syntax into
;;; Scheme code, and the actual implementation are due to Kent Dybvig.

;;; Made available courtesy R. Kent Dybvig
;;; MacScheme conversion by Jeff De Vries
;;; note: requires the use of MacScheme Version 1.2 or greater
;;; Scheme->C conversion by Hakan Huss

;;; gensym (Huss) -- Scheme->C doesn't have it...
(eval-when (compile eval)		; Note absence ov 'load'
  (define gensym
    (let ((i 0))
      (lambda arg
	(set! i (+ i 1))
	(string->uninterned-symbol (string-append
				    (if (null? arg)
					"G"
					(car arg) )
				    (number->string i '(int)) ))))) )

(eval-when (compile eval)
  (define (andmap p . args)
    ;; use "first-finish" rule
    (let andmap ((args args) (value #t))
      (if (let any-at-end? ((ls args))
	    (and (pair? ls)
		 (or (not (pair? (car ls)))
		     (any-at-end? (cdr ls)))))
	  value
	  (let ((value (apply p (map car args))))
	    (and value (andmap (map cdr args) value)) ))))

  ;; ormap (Huss) -- for some reason wasn't included even though andmap was...
  (define (ormap p . args)
    ;; use "first-finish" rule
    (let ormap ((args args) (value #f))
      (if (let any-at-end? ((ls args))
	    (and (pair? ls)
		 (or (not (pair? (car ls)))
		     (any-at-end? (cdr ls)))))
	  value
	  (let ((value (apply p (map car args))))
	    (or value (ormap (map cdr args) value)) ))))
  )

;;; syntax-match? is used by extend-syntax to choose among clauses and
;;; to check for syntactic errors.  It is also available to the user.
(eval-when (compile eval)
  (define syntax-match?
    (lambda (keys pat exp)
      (cond
       ((symbol? pat) (if (memq pat keys) (eq? exp pat) #t))
       ((pair? pat)
	(if (equal? (cdr pat) '(...))
	    (let f ((lst exp))
	      (or (or (not lst) (null? lst))
		  (and (pair? lst)
		       (syntax-match? keys (car pat) (car lst))
		       (f (cdr lst)))))
	    (and (pair? exp)
		 (syntax-match? keys (car pat) (car exp))
		 (syntax-match? keys (cdr pat) (cdr exp)))))
       (else (equal? exp pat)) ))) )

;;; The main code!
(eval-when (compile eval)
  (define id
    (lambda (name access control)
      (list name access control)))
  (define id-name car)
  (define id-access cadr)
  (define id-control caddr)
  
  (define loop
    (lambda ()
      (list '())))
  (define loop-ids car)
  (define loop-ids! set-car!)
  
  (define c...rs
    `((car caar . cdar)
      (cdr cadr . cddr)
      (caar caaar . cdaar)
      (cadr caadr . cdadr)
      (cdar cadar . cddar)
      (cddr caddr . cdddr)
      (caaar caaaar . cdaaar)
      (caadr caaadr . cdaadr)
      (cadar caadar . cdadar)
      (caddr caaddr . cdaddr)
      (cdaar cadaar . cddaar)
      (cdadr cadadr . cddadr)
      (cddar caddar . cdddar)
      (cdddr cadddr . cddddr)))
  
  (define add-car
    (lambda (access)
      (let ((x (and (pair? access) (assq (car access) c...rs))))
	(if (or (not x) (null? x))
	    `(car ,access)
	    `(,(cadr x) ,@(cdr access))))))
  
  (define add-cdr
    (lambda (access)
      (let ((x (and (pair? access) (assq (car access) c...rs))))
	(if (or (not x) (null? x))
	    `(cdr ,access)
	    `(,(cddr x) ,@(cdr access))))))
  
  (define parse
    (lambda (keys pat acc cntl ids)
      (cond
       ((symbol? pat)
	(if (memq pat keys)
	    ids
	    (cons (id pat acc cntl) ids)))
       ((pair? pat)
	(if (equal? (cdr pat) '(...))
	    (let ((x (gensym)))
	      (parse keys (car pat) x (id x acc cntl) ids))
	    (parse keys
		   (car pat)
		   (add-car acc)
		   cntl
		   (parse keys (cdr pat) (add-cdr acc) cntl ids))))
       (else ids))))
  
  (define gen
    (lambda (keys exp ids loops)
      (cond
       ((symbol? exp)
	(let ((id (extend-lookup exp ids)))
	  (if (or (not id) (null? id))
	      exp
	      (begin
		(add-control! (id-control id) loops)
		(list 'unquote (id-access id))))))
       ((pair? exp)
	(cond
	 ((eq? (car exp) 'with)
	  (unless (syntax-match? '(with) '(with ((p x) ...) e) exp)
		  (error 'extend-syntax "invalid 'with' form: ~a" exp))
	  (list 'unquote
		(gen-with
		 keys
		 (map car (cadr exp))
		 (map cadr (cadr exp))
		 (caddr exp)
		 ids
		 loops)))
	 ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
	  (let ((x (loop)))
	    (make-loop
	     x
	     (gen keys (car exp) ids (cons x loops))
	     (gen keys (cddr exp) ids loops))))
	 (else
	  (let ((a (gen keys (car exp) ids loops))
		(d (gen keys (cdr exp) ids loops)))
	    (if (and (pair? d) (eq? (car d) 'unquote))
		(list a (list 'unquote-splicing (cadr d)))
		(cons a d))))))
       (else exp))))
  
  (define gen-with
    (lambda (keys pats exps body ids loops)
      (if (or (not pats) (null? pats))
	  (make-quasi (gen keys body ids loops))
	  (let ((p (car pats)) (e (car exps)) (g (gensym)))
	    `(let ((,g ,(gen-quotes keys e ids loops)))
	       (if (syntax-match? '() ',p ,g)
		   ,(gen-with
		     keys
		     (cdr pats)
		     (cdr exps)
		     body
		     (parse '() p g '() ids)
		     loops)
		   (error ',(car keys)
			  "does not fit 'with' pattern: ~a ~a"
			  ,g
			  ',p)))))))
  
  (define gen-quotes
    (lambda (keys exp ids loops)
      (cond
       ((syntax-match? '(quote) '(quote x) exp)
	(make-quasi (gen keys (cadr exp) ids loops)))
       ((pair? exp)
	(cons (gen-quotes keys (car exp) ids loops)
	      (gen-quotes keys (cdr exp) ids loops)))
       (else exp))))
  
  (define extend-lookup
    (lambda (sym ids)
      (let loop ((ls ids))
	(cond
	 ((null? ls) #f)
	 ((eq? (id-name (car ls)) sym) (car ls))
	 (else (loop (cdr ls)))))))
  
  (define add-control!
    (lambda (id loops)
      (unless (or (not id) (null? id))
	      (when (or (not loops) (null? loops))
		    (error 'extend-syntax "missing ellipsis in expansion"))
	      (let ((x (loop-ids (car loops))))
		(unless (memq id x)
			(loop-ids! (car loops) (cons id x))))
	      (add-control! (id-control id) (cdr loops)))))
  
  (define make-loop
    (lambda (loop body tail)
      (let ((ids (loop-ids loop)))
	(when (or (not ids) (null? ids))
	      (error 'extend-syntax "extra ellipsis in expansion"))
	(cond
	 ((equal? body (list 'unquote (id-name (car ids))))
	  (if (or (not tail) (null? tail))
	      (list 'unquote (id-access (car ids)))
	      (cons (list 'unquote-splicing (id-access (car ids)))
		    tail)))
	 ((and (null? (cdr ids))
	       (syntax-match? '(unquote) '(unquote (f x)) body)
	       (eq? (cadadr body) (id-name (car ids))))
	  (let ((x `(map ,(caadr body) ,(id-access (car ids)))))
	    (if (or (not tail) (null? tail))
		(list 'unquote x)
		(cons (list 'unquote-splicing x) tail))))
	 (else
	  (let ((x `(map (lambda ,(map id-name ids) ,(make-quasi body))
			 ,@(map id-access ids))))
	    (if (or (not tail) (null? tail))
		(list 'unquote x)
		(cons (list 'unquote-splicing x) tail))))))))
  
  (define make-quasi
    (lambda (exp)
      (if (and (pair? exp) (eq? (car exp) 'unquote))
	  (cadr exp)
	  (list 'quasiquote exp))))
  
  (define make-clause
    (lambda (keys cl x)
      (cond
       ((syntax-match? '() '(pat fender exp) cl)
	(let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
	  (let ((ids (parse keys pat x '() '())))
	    `((and (syntax-match? ',keys ',pat ,x)
		   ,(gen-quotes keys fender ids '()))
	      ,(make-quasi (gen keys exp ids '()))))))
       ((syntax-match? '() '(pat exp) cl)
	(let ((pat (car cl)) (exp (cadr cl)))
	  (let ((ids (parse keys pat x '() '())))
	    `((syntax-match? ',keys ',pat ,x)
	      ,(make-quasi (gen keys exp ids '()))))))
       (else
	(error 'extend-syntax "invalid clause: ~a" cl)))))
  
  (define make-syntax
    (lambda (keys clauses x)
      `(cond
	,@(map (lambda (cl) (make-clause keys cl x)) clauses)
	(else
	 (error ',(car keys) "invalid syntax: ~s" ,x)))))
  
;;; End of eval-when (compile eval)
  )

(eval-when (compile load eval)
  (define-macro extend-syntax
    (let ((x (gensym "X")))
      (lambda (form expander)
	(expander
	 (cond
	  ((and
	    (syntax-match?
	     '(extend-syntax)
	     '(extend-syntax (key1 key2 ...) clause ...)
	     form)
	    (andmap symbol? `(,(caadr form) ,@(cdadr form))))
	   (let ((f (make-syntax `(,(caadr form)
				   ,@(cdadr form))
				 (cddr form) x)))
	     (if (syntax-match? '() 'proc f)
		 `(define-macro ,(caadr form)
		    (lambda (,x e)
		      (e ,f e) ))
		 (error 'extend-syntax
			"does not fit 'with' pattern: ~a ~a"
			f
			'proc))))
	  (else (error 'extend-syntax "invalid syntax: ~a" form)))
	 expander ))))
  
  (define-macro extend-syntax/code
    (let ((x (gensym "X")))
      (lambda (form expander)
	(expander
	 (cond
	  ((and
	    (syntax-match?
	     '(extend-syntax/code)
	     '(extend-syntax/code (key1 key2 ...) clause ...)
	     form)
	    (andmap symbol? `(,(caadr form) ,@(cdadr form))))
	   (let ((f (make-syntax `(,(caadr form)
				   ,@(cdadr form))
				 (cddr form) x)))
	     (if (syntax-match? '() 'proc f)
		 `',f
		 (error 'extend-syntax/code
			"does not fit 'with' pattern: ~a ~a"
			f
			'proc))))
	  (else (error 'extend-syntax/code "invalid syntax: ~a" form)))
	 expander ))))
  
  ) ;;; End of eval-when