; Parser that yields an S-expression

(define (parse stx phase)
  (let parse ((stx stx))
    (cond
     ((identifier? stx)
      (resolve+label-symbol stx phase))
     (else
      (let ((e (syntax-e stx)))
	(cond
	 ((null? e) '())
	 ((vector? e)
	  (list->vector (map parse (vector->list e))))
	 ((pair? e)
	  (cond
	   ((operator-syntax (car e))
	    => (lambda (op)
		 (parse-operator-form op e parse)))
	   (else (map parse e))))
	 (else
	  (let ((d (syntax->datum stx)))
	    (if (self-quoting? d)
		d
		(assertion-violation 'parse "invalid syntax" stx))))))))))

(define parsers
  (make-operator-table (lambda (e parse)
			 (map parse e))))

(define (parse-operator-form op e parse)
  ((operator-table-ref parsers (operator-uid op))
   e parse))

(define (define-parser name proc)
  (operator-define! parsers name #f proc))

(define-parser 'call
  (lambda (e parse)
    (map parse (cdr e))))

(define-parser 'lambda
  (lambda (e parse)
    `(lambda ,(resolve-formals->symbols (cadr e)) ,(parse (caddr e)))))

; not enough commonality with resolve-formals->nodes (Mike tried hard)
(define (resolve-formals->symbols formals)
  (if (identifier? formals)
      (resolve+label-symbol formals 0)
      (let loop ((formals-e (syntax-e formals))
		 (new-formals '()))
	(cond
	 ((null? formals-e) (reverse new-formals))
	 ((pair? formals-e)
	  (loop (cdr formals-e)
		(cons (resolve+label-symbol (car formals-e) 0)
		      new-formals)))
	 (else
	  (append (reverse new-formals)
		  (resolve+label-symbol formals-e 0)))))))

(define-parser 'begin
  (lambda (e parse)
    `(begin ,@(map parse (cdr e)))))

(define-parser 'letrec
  (lambda (e parse)
    `(letrec ,(map (lambda (spec)
		     (let ((b (syntax-e spec)))
		       (list (resolve+label-symbol (car b) 0)
			     (parse (cadr b)))))
		   (syntax-e (cadr e)))
       ,(parse (caddr e)))))

(define-parser 'quote
  (lambda (e parse)
    `(quote ,(syntax->datum (cadr e)))))

(define-parser 'code-quote
  (lambda (e parse)
    `(code-quote ,(cadr e))))

(define-parser 'set!
  (lambda (e parse)
    `(set! ,(resolve+label-symbol (cadr e) 0) ,(parse (caddr e)))))

(define-parser 'if
  (lambda (e parse)
    `(if ,@(map parse (cdr e)))))

(define-parser 'define
  (lambda (e parse)
    `(define ,(parse (cadr e)) ,(parse (caddr e)))))

(define-parser 'primitive-procedure
  (lambda (e parse)
    `(primitive-procedure ,(parse (cadr e)))))

(define (resolve+label-symbol stx phase)
  (label->symbol (resolve+label stx phase)))

(define (label->symbol lbl)
  (cond
   ((symbol? lbl) lbl)
   ((sym? lbl)
    (string->symbol (string-append (sym-pretty-string lbl)
				   "-"
				   (sym-unique-string lbl))))
   (else
    (assertion-violation 'label->symbol "invalid label" lbl))))

; Parser that yields a node

(define (parse->node stx env)
  (let ((e (syntax-e stx)))
    (cond
     ((null? e)
      (assertion-violation 'parse->node "invalid form" e))
     ((pair? e)
      (cond
       ((operator-syntax (car e))
	=> (lambda (op)
	     (parse->node-operator-form op e env)))
       (else
	(make-node operator/call (map (lambda (stx)
					(parse->node stx env))
				      e)))))
     ((identifier? stx)
      (call-with-values
	  (lambda () (resolve+lookup stx env))
	(lambda (lbl l)
	  (if (node? l)
	      l
	      (let ((node (make-node operator/name lbl)))
		(node-set! node 'binding (or l 'unbound))
		node)))))
     (else
      (let ((d (syntax->datum stx)))
	(if (self-quoting? d)
	    (make-node operator/quote `(quote ,d))
	    (assertion-violation 'parse->node "invalid syntax" stx)))))))

(define (static-value form)
  (if (and (node? form)
	   (name-node? form))
      (let ((probe (node-ref form 'binding)))
	(if (binding? probe)
	    (binding-static probe)
	    #f))
      #f))

(define parsers->node
  (make-operator-table (lambda (e env)
			 (make-node operator/call (map (lambda (stx)
							 (parse->node stx env))
						       e)))))

(define (parse->node-operator-form op e env)
  ((operator-table-ref parsers->node (operator-uid op))
   e env))

(define (define-parser->node name proc)
  (operator-define! parsers->node name #f proc))

(define-parser->node 'call
  (lambda (e env)
    (make-node operator/call
	       (map (lambda (stx)
		      (parse->node stx env))
		    (cdr e)))))

(define-parser->node 'lambda
  (lambda (e env)
    (call-with-values
	(lambda ()
	  (resolve-formals->nodes (cadr e) env))
      (lambda (formals env)
	(make-node operator/lambda
		   `(lambda ,formals
		      ,(parse->node (caddr e) env)))))))

(define (resolve-formals->nodes formals-stx env)
  (let ((phase (env-phase env)))
    (if (identifier? formals-stx)
	(let* ((lbl (resolve+label formals-stx phase))
	       (formal (parameter->node lbl)))
	  (values formal (bind1 lbl formal env)))
	(let loop ((formals-e (syntax-e formals-stx))
		   (labels '())
		   (formals '()))
	  (cond
	   ((null? formals-e)
	    (values (reverse formals) 
		    (bind labels formals env)))
	   ((pair? formals-e)
	    (let* ((lbl (resolve+label (car formals-e) phase))
		   (formal (parameter->node lbl)))
	      (loop (cdr formals-e)
		    (cons lbl labels)
		    (cons formal formals))))
	   (else
	    (let* ((lbl (resolve+label formals-e phase))
		   (formal (parameter->node lbl)))
	      (values (append (reverse formals) formal)
		      (bind (cons lbl labels) (cons formal formals) env)))))))))

(define (parameter->node lbl)
  (make-node operator/name lbl))

(define-parser->node 'begin
  (lambda (e env)
    (make-node operator/begin
	       `(begin ,@(map (lambda (stx) (parse->node stx env)) (cdr e))))))

(define-parser->node 'letrec
  (lambda (e env)
    (let* ((specs (map syntax-e (syntax-e (cadr e))))
	   (phase (env-phase env))
	   (names (map (lambda (spec)
			 (resolve+label (car spec) phase))
		       specs))
	   (nodes (map parameter->node names))
	   (env (bind names nodes env)))
    (make-node operator/letrec
	       `(letrec ,(map (lambda (spec node)
				(list node
				      (parse->node (cadr spec) env)))
			      specs nodes)
		  ,(parse->node (caddr e) env))))))

(define-parser->node 'quote
  (lambda (e env)
    (make-node operator/quote `(quote ,(syntax->datum (cadr e))))))

(define-parser->node 'code-quote
  (lambda (e env)
    (make-node operator/quote `(code-quote ,(cadr e)))))

(define-parser->node 'set!
  (lambda (e env)
    (make-node operator/set! `(set! ,(parse->node (cadr e) env) ,(parse->node (caddr e) env)))))

(define-parser->node 'if
  (lambda (e env)
    (make-node operator/if `(if ,@(map (lambda (stx) (parse->node stx env)) (cdr e))))))

(define-parser->node 'define
  (lambda (e env)
    (make-node operator/define `(define ,(parse->node (cadr e) env) ,(parse->node (caddr e) env)))))

(define-parser->node 'primitive-procedure
  (lambda (e env)
    (make-node operator/primitive-procedure `(primitive-procedure ,(syntax-object-expr (cadr e))))))

(define (unspecific-node)
  (make-node operator/unspecific '(unspecific)))
