;;;; core.scm


(define (add-undefined var)
  (unless (memq var undefined)
    (set! undefined (cons var undefined))))

(define (add-access var assign)
  (let ((d (get var 'defined)))
    (if d
	(when (and (symbol? d) (not (memq d used-sections)))
	  (set! used-sections (cons d used-sections)))
	(add-undefined var))
    (cond (assign 
	   (unless (get var 'assigned)
	     (put! var 'assigned #t)
	     (set! assigned (cons var assigned))))
	  ((not (get var 'referenced))
	   (put! var 'referenced #t)
	   (set! referenced (cons var referenced))))))

(define (canonicalize form state)
  (let ((looping #f)
	(debug-mode (test-option 'debug state))
	(xref-mode (test-option 'xref state))
	(strict-mode (test-option 'strict state)))
    (define (match-llist? llist args)
      (let loop ((ll llist) (args args))
	(cond ((null? ll) (null? args))
	      ((symbol? ll))
	      ((null? args) #f)
	      (else (loop (cdr ll) (cdr args))))))
    (define (dotted? name)
      (string-find-char #\. (stringify name)))
    (define (normalize-ref ref)
      (let* ((str (stringify ref))
	     (len (string-length str)))
	(cond ((char=? #\. (string-ref str 0))
	       (normalize-ref (substring str 1 len)))
	      ((char=? #\. (string-ref str (- len 1)))
	       (normalize-ref (substring str 0 (- len 1))))
	      (else str))))
    (define (walk x e tail ldest)
      ;;(pp x)
      (match x
	((or (? char?) (? number?) (? string?) (? boolean?))
	 `(quote ,x))
	((? symbol?)
	 (if (and (not strict-mode) (dotted? x))
	     (let ((str (symbol->string x)))
	       (cond ((char=? #\. (string-ref str 0))
		      `(%property-ref ,(normalize-ref str)))
		     (else
		      `(%host-ref ,(normalize-ref str)))))
	     (cond ((assq x e) => cdr)
		   (else
		    (when xref-mode (add-access x #f))
		    `(%global-ref ,x)))))
	(('set! x y)
	 (let ((y (walk y e #f #f)))
	   (if (and (not strict-mode) (dotted? x))
	       `(%host-set! ,(normalize-ref x) ,y)
	       (cond ((assq x e) => (lambda (a) `(set! ,(cdr a) ,y)))
		     (else
		      (when xref-mode
			(put! x 'assigned #t)
			(add-access x #t))
		      `(%global-set! ,x ,y))))))
	(('quote _) x)
	(('if x y) 
	 `(if ,(walk x e #f #f)
	      ,(walk y e tail ldest) 
	      (%void)))
	(('if x y z)
	 `(if ,(walk x e #f #f)
	      ,(walk y e tail ldest)
	      ,(walk z e tail ldest)))
	((('lambda _ ('%dispatch lambdas ...)) args ...)
	 (let loop ((ls lambdas))
	   (if (or (null? (cdr ls))
		   (match-llist? (cadar ls) args))
	       (walk `(,(car ls) ,@args) e tail ldest)
	       (loop (cdr ls)))))
	((('lambda () body ...))
	 (walk `(begin ,@body) e #t ldest))
	((('lambda llist body ...) args ...)
	 (match-let (((vars rest) (parse-llist llist)))
	   (let ((aliases (map (lambda (v) (cons v (temp))) vars)))
	     (let loop ((as aliases) (vars vars) (args args))
	       (cond ((null? as)
		      ;; handle surplus arguments
		      (let loop2 ((args args))
			(if (null? args)
			    (walk 
			     `(begin ,@body) 
			     (append aliases e)
			     tail ldest)
			    `(let ((%unused ,(walk (car args) e #f #f)))
			       ,(loop2 (cdr args))))))
		     ((eq? rest (caar as))
		      `(let ((,(cdar as) ,(walk `(%list ,@args) e #f (car vars))))
			 ,(loop '() '() '())))
		     ((null? args)
		      `(let ((,(cdar as) (%void)))
			 ,(loop (cdr as) (cdr vars) '())))
		     (else
		      `(let ((,(cdar as) ,(walk (car args) e #f (car vars))))
			 ,(loop (cdr as) (cdr vars) (cdr args)))))))))
	(('lambda _ ('%dispatch lambdas ...))
	 (walk (last lambdas) e tail ldest))
	(('letrec () body ...)
	 (walk `(begin ,@body) e tail ldest))
	(('letrec ((vars vals) ...) body ...)
	 (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
		(e2 (append aliases e)))
	   (let loop1 ((as aliases))
	     (if (null? as)
		 (if strict-mode
		     (let ((temps (map (lambda _ (temp)) aliases)))
		       (let loop2 ((tmps temps) (vals vals))
			 (if (null? tmps)
			     (let loop3 ((as aliases) (temps temps))
			       (if (null? as) 
				   (walk `(begin ,@body) e2 tail #f)
				   `(let ((%unused (set! ,(cdar as) ,(car temps))))
				      ,(loop3 (cdr as) (cdr temps)))))
			     `(let ((,(car tmps) ,(walk (car vals) e2 #f #f)))
				,(loop2 (cdr tmps) (cdr vals))))))
		     (let loop2 ((as aliases) (vars vars) (vals vals))
		       (if (null? as) 
			   (walk `(begin ,@body) e2 tail #f)
			   `(let ((%unused
				   (set! ,(cdar as) ,(walk (car vals) e2 #f (car vars)))))
			      ,(loop2 (cdr as) (cdr vars) (cdr vals))))))
		 `(let ((,(cdar as) (%void)))
		    ,(loop1 (cdr as)))))))
	(('%check type x)
	 (if (not debug-mode)
	     (walk x e tail ldest)
	     `(%check ,type ,(walk x e tail ldest))))
	(('%check x)
	 (if (not debug-mode)
	     ''#t
	     (walk x e tail ldest)))
	(((or '%void '%void?) args ...)
	 `(,(car x) ,@(map (cut walk <> e #f #f) args)))
	(('%host-ref (or ('quote name) name))
	 `(%host-ref ,(normalize-ref name)))
	(('%host-set! (or ('quote name) name) x)
	 `(%host-set! ,(normalize-ref name) ,(walk x e #f #f)))
	(('%syntax-error msg . arg)
	 (apply fail msg arg))
	(('%new args ...) 
	 `(%new ,@(map (cut walk <> e #f #f) args)))
	(('%property-ref (or ('quote name) name) x)
	 `(%property-ref ,(normalize-ref name) ,(walk x e #f #f)))
	(('%property-ref (or ('quote name) name))
	 `(%property-ref ,(normalize-ref name)))
	(('%property-set! (or ('quote name) name) x y)
	 `(%property-set!
	   ,(normalize-ref name)
	   ,(walk x e #f #f)
	   ,(walk y e #f #f)))
	(('%inline (or name ('quote name)) xs ...) 
	 `(%inline ,name ,@(map (cut walk <> e #f #f) xs)))
	(((or '%native-lambda '%code) code ...) x)
	(('begin x) (walk x e tail ldest))
	(('begin) '(%void))
	(('begin x1 . more)
	 `(let ((%unused ,(walk x1 e #f #f)))
	    ,(walk `(begin ,@more) e tail ldest)))
	(('lambda llist body ...)
	 (set! looping #f)
	 (match-let (((vars rest) (parse-llist llist)))
	   (let* ((aliases (map (lambda (v) (cons v (temp))) vars))
		  (newllist
		   (append 
		    (map cdr (if rest (butlast aliases) aliases))
		    (if rest
			(cdr (assq rest aliases))
			'()))))
	     `(lambda ,newllist
		,(fluid-let ((looping #t))
		   ;; walking body checks for self-call in tail-pos. and sets `looping'
		   (let ((body (walk `(begin ,@body) (append aliases e) #t ldest)))
		     (if looping
			 `(%loop ,newllist ,body)
			 body)))))))
	(('define v x)
	 (when (and xref-mode
		    (not (get v 'defined)))
	   (put! v 'defined #t)
	   (set! defined (cons v defined)))
	 `(%global-set! ,v ,(walk x e #f #f)))
	;;XXX we actually have to check `op' for not being a special form name
	((op args ...)
	 (cond ((and tail (symbol? op) (eq? op ldest)) ; tail + self call?
		`(%continue ,@(map (cut walk <> e #f #f) x)))
	       (else
		(set! looping #f)
		(map (cut walk <> e #f #f) x))))
	(_ (fail "bad expression" x))))
    (walk form '() #t #f)))

;; CPS-conversion algorithm from "Essentials of Programming Languages"
(define (cps form)
  (let ((toplambdas '()))
    (define (zero x)
      (let ((k (temp "k")))
	`(lambda (,k) ,(one x k))))	; Cpgm
    (define (one x k)
      (match x
	(('let ((v x)) y)		; canonicalizer only generates single-var `let'
	 (if (simple? x)
	     `(let ((,v ,(two x)))	; Clet
		,(one y k))
	     (let ((t (temp)))		; Chead
	       (one x `(lambda (,t)
			 (let ((,v ,t))
			   ,(one y k)))))))
	((? simple?)
	 (callk k (lambda () x)))
	;; from here on `x' is non-simple
	(((or 'set! '%global-set! '%host-set!) v y)
	 (let ((t (temp)))
	   (one y `(lambda (,t)		; Chead
		     (let ((%unused (,(car x) ,v ,t)))
		       ,(callk k (lambda () '(%void))))))))
	(('if x y z)
	 (if (simple? x)
	     (bindk
	      k
	      (lambda (k)		; Cif
		`(if ,(two x)
		     ,(one y k)
		     ,(one z k))))
	     (let ((t (temp)))		; Chead
	       (one x `(lambda (,t)
			 (if ,t 
			     ,(one y k)
			     ,(one z k)))))))
	(('%loop llist x) `(%loop ,llist ,(one x k)))
	(('%continue args ...)
	 (head
	  args
	  (lambda (args2)
	    `(%continue ,(car args2) ,k ,@(cdr args2)))))
	(((or '%property-set! '%inline) info xs ...)
	  ;; simple %inline/%property-set! form is already handled above
	 (head 
	  xs
	  (lambda (xs2)
	    (callk k (lambda () `(,(car x) ,info ,@xs2))))))
	(('%check type x)		; s.a.
	 (head 
	  (list x)
	  (lambda (xs2)
	    (callk k (lambda () `(%check ,type ,@xs2))))))
	(('%new args ...)
	 (head
	  args
	  (lambda (args2)
	    (callk k (lambda () `(%new ,@args2))))))
	(((? simple?) ...)		; Capp
	 (cons (two (car x)) (cons k (map two (cdr x)))))
	((xs ...)
	 (head
	  xs
	  (lambda (xs2) (cons (car xs2) (cons k (cdr xs2))))))
	(else (error "one" x k))))
    (define (two x)
      (match x
	((? symbol?) x)
	(('lambda llist body)		; Cproc
	 (let ((k (temp "k")))
	   `(lambda (,k . ,llist) ,(one body k))))
	(('if xs ...) `(if ,@(map two xs)))
	(((or '%inline '%property-set!) info xs ...) 
	 `(,(car x) ,info ,@(map two xs)))
	(((or 'set! '%global-set! '%check) v y) `(,(car x) ,v ,(two y)))
	(((or 'quote '%host-ref '%code '%native-lambda '%void) . _) x)
	(('%property-ref parts) x)
	(((or '%host-set! '%property-ref) parts y) 
	 `(,(car x) ,parts ,(two y)))
	(('let ((var x)) y)
	 `(let ((,var ,(two x))) ,(two y)))
	(((or '%new '%continue '%void?) xs ...) `(,(car x) ,@(map two xs)))
	((xs ...) (map two xs))
	(_ (error "two" x))))
    (define (bindk k proc)
      (if (symbol? k)
	  (proc k)
	  (let ((t (temp)))
	    `(let ((,t ,k))
	       ,(proc t)))))
    (define (callk k thunk)
      (if (symbol? k)
	  `(,k ,(two (thunk)))	      ; Csimplevar
	  (let ((v (caadr k)))	      ; Csimpleproc
	    `(let ((,v ,(two (thunk))))     ;XXX must we `two' here as well?
	       ,(caddr k)))))
    (define (head xs wrap)
      (let loop ((xs xs) (xs2 '()))	; Chead
	(if (null? xs)
	    (wrap (reverse xs2))
	    (let ((x (car xs)))
	      (if (simple? x)
		  (loop (cdr xs) (cons (two x) xs2))
		  (let ((t (temp)))
		    (one x `(lambda (,t) 
			      ,(loop (cdr xs) (cons t xs2))))))))))
    (define (simple? x)
      (match x
	(((or '%host-ref '%code 'lambda 'quote '%global-ref '%void
	      '%native-lambda) . _)
	 #t)
	(('%property-ref _) #t)
	(((or '%host-set! '%property-ref) _ x) (simple? x))
	((? symbol?) #t)
	(('if (? simple?) ...) #t)
	(('%void? (? simple?)) #t)
	(('let ((_ (? simple?))) (? simple?)) #t)
	(((or 'set! '%inline '%global-set! '%check '%new '%property-set!) _ (? simple?) ...)
	 #t)
	(((or '%loop '%continue) . _) #f)
	(_ #f)))
    (define (sequence parts)
      (let loop ((parts parts))
	(if (null? (cdr parts))
	    (car parts)
	    `(let (,(car parts))
	       ,(loop (cdr parts))))))
    (define (toplambda parts)
      (set! toplambdas (cons (zero (sequence parts)) toplambdas)))
    (define (top x parts)
      ;; perform "clustering": build groups of toplevel forms
      ;; transformed together to reduce function nesting
      ;; XXX is this still needed, or does this pay off?
      (match x
	(('let ((_ (? simple?))) y)
	 (top y (cons (caadr x) parts)))
	(('let (('%unused z)) y)
	 (toplambda (reverse (cons z parts)))
	 (top y '()))
	(_ (toplambda
	    (if (null? parts)
		(list x)
		(reverse (cons x parts)))))))
    (top form '())
    (reverse toplambdas)))