;;; Scanner and Parser for Stacks example

(printf "syntax.s Fri May 28 11:11:46 1993~%")

;;; Assumes parse-utils.s is loaded (includes scanner)

;;; Also some common routines (eg primops)

;;; **********************************************************

;;; Top-level interface

(define scan&parse
  (lambda (string)
    (parse-top-level grammar-9
      (string->token-stream automaton-9 string))))

;;; ***********************************************************

;;; Lexical Specification

;;; same as automaton-4

(define automaton-9
  '((start-state
      (cond
        (#\space (drop (goto start-state)))
        (#\tab (drop (goto start-state)))
        (#\newline (drop (goto start-state)))
        (alphabetic (shift (goto identifier-state)))
        (numeric (shift (goto number-state)))
        (#\, (drop (emit comma)))
        (#\; (drop (emit semicolon)))
        (#\+ (shift (goto identifier-state)))
        (#\- (goto identifier-state))
        (#\* (goto identifier-state))
        (#\/ (shift (goto identifier-state)))
        (#\= (goto identifier-state))
        (#\( (drop (emit lparen)))
        (#\) (drop (emit rparen)))
        (#\nul (emit end-marker))
        (#\^ (emit end-marker))         ; use ^ or \nul as end-marker
        (#\% (drop (goto comment-state)))))
    (identifier-state
      (cond
        (alphabetic (shift (goto identifier-state)))
        (numeric (shift (goto identifier-state)))
        (#\* (shift (goto identifier-state)))
        (#\+ (shift (goto identifier-state)))
        (#\- (shift (goto identifier-state)))
        (#\/ (shift (goto identifier-state)))
        (#\! (shift (goto identifier-state)))
        (#\= (shift (goto identifier-state)))
        (#\? (shift (goto identifier-state)))
        (else (emit cook-identifier))))
    (comment-state
      (cond
        (#\newline (drop (goto start-state)))
        (else (drop (goto comment-state)))))
    (number-state
      (cond
        (numeric (shift (goto number-state)))
        (else (emit cook-number))))
    ))

;;; Keywords for our language are defined as follows:

(define **keywords-list** '(if then else letrec in =))

;;; ****************************************************************

;;; Grammar

(define grammar-9
  '((start-state
      ((goto expression)))
    (expression
      (cond
        (number
          ((check/shift number)
           (reduce lit-exp)))
        (identifier
          ((check/shift identifier)
           (reduce var-exp)))
        (if
          ((check/drop if)
           (process-nt expression)
           (check/drop then)
           (process-nt expression)
           (check/drop else)
           (process-nt expression)
           (reduce if-exp)))
        (letrec
          ((check/drop letrec)
           (process-nt declaration-list)
           (check/drop in)
           (process-nt expression)
           (reduce letrec-exp)))
        (lparen
          ((check/drop lparen)
           (check/shift identifier)          ; operator must be an identifier
           (process-nt operand-list)
           (check/drop rparen)
           (reduce app-exp)))))
  (declaration
    (cond
      (lparen
        ((check/drop lparen)
         (check/shift identifier)
         (process-nt formal-parameter-list)
         (check/drop rparen)
         (check/drop =)
         (process-nt expression)
         (reduce rec-decl)))))
  (declaration-list                     ; bounded by "in"
    (cond
      (in
        ((emit-list)))
      (else
        ((process-nt declaration)
         (goto declaration-list)))))
  (formal-parameter-list		; bounded by rparen
    (cond
      (rparen
        ((emit-list)))
      (else
        ((check/shift identifier)	
         (goto formal-parameter-list)))))
  (operand-list                         ; bounded by rparen
    (cond
      (rparen
        ((emit-list)))
      (else
        ((process-nt expression)
         (goto operand-list)))))
    ))
       
;;; End of syntactic specification

;;; *****************************************************************
;;; *****************************************************************

;;; Some common things for all interpreters:

;;; *****************************************************************

;;; Data Structure Definitions

(define-record rec-decl (name formals body))

(define-record empty-env ())
(define-record extended-env (names vals old-env))
(define-record extended-rec-env (decls env))

;; unnecessary after interp1.s
(define-record closure (rec-decl env)) 


;;; *****************************************************************

;;; Primops

(define-record prim-1 (unary-op))
(define-record prim-2 (binary-op))

(define apply-unary-primop
  (lambda (primop arg)
    (case primop
      ((+1-op) (+ arg 1))
      ((-1-op) (- arg 1))
      ((zero-op) (if (zero? arg) 1 0))
      (else (error 'apply-unary-primop "Unknown Primop: ~s"
              primop)))))

(define apply-binary-primop
  (lambda (primop arg1 arg2)
    (case primop
      ((+-op)  (+ arg1 arg2))
      ((--op)  (- arg1 arg2))
      ((*-op)  (* arg1 arg2))
      (else (error 'apply-binary-primop "Unknown Primop: ~s"
              primop)))))

;; this gets grouped with the primops

(define true-value?
  (lambda (v)
    (not (zero? v))))

;;; ****************************************************************

;;; The Initial Environment

(define init-entries
  '((+ +-op 2)
    (- --op 2)
    (* *-op 2)
    (add1 +1-op 1)
    (sub1 -1-op 1)
    (zero? zero-op 1)))

(define make-init-env 
  (lambda () (build-init-env init-entries)))

;;; ****************************************************************

(define debug-print
  (lambda (s . l)                       ; optional 2nd arg is starting point
    (let ((sp (if (null? l) (stack->sp s) (car l))))
      (letrec
        ((loop (lambda (kp n)
                 (if (or (zero? kp) (zero? n))
                   (printf "~%")
                   (begin
                     (printf "a[~s] = ~s~%" kp (stack-ref s kp))
                     (loop (- kp 1) (- n 1)))))))
        (printf "sp = ~s bp = ~s~%" 
          (stack->sp s)
          (stack->bp s))
        (loop sp 10)))))

(define debug-points '())