#lang eopl
;;----------------------------------------------------------------------------------------
;; BlooP/FlooP interpreter
;;
;; Written by Jim Marshall
;;
;; This code implements an interpreter for the languages BlooP and FlooP
;; discussed in Chapter XIII of GEB.  It must be run in DrRacket with the
;; Language setting on "The Racket Language".  To run in Petite Chez Scheme,
;; comment out #lang eopl and use the petite-eopl command.
;;
;; version 1.0: spring 2011
;; version 1.1: spring 2016 - updated for DrRacket, added support for builtins
;; 
;;----------------------------------------------------------------------------------------
;; Usage:
;;
;; > (start)                       starts the interpreter
;; ==> (load "filename")           loads FlooP definitions from a file and prints them out
;; ==> (load-quietly "filename")   same as load but without printing anything
;; ==> (print <procedure>)         prints out a FlooP procedure
;; ==> (godel-number <procedure>)  the procedure's Godel number
;; ==> (length <procedure>)        the procedure's length in characters
;; ==> (length <number>)           the number of digits of a number
;; ==> (print environment)         prints the current environment contents
;; ==> exit                        ends the interpreter session
;; > (restart)                     restarts the interpreter with the previous
;;                                 environment still in effect
;; Examples:
;;
;; ==> (load "floop-defs.txt")
;; ==> (print minus)
;; ==> (print factorial)
;; ==> (length factorial)
;; ==> (godel-number factorial)
;; ==> (length (godel-number factorial))
;; ==> (factorial 5)
;; ==> (print wondrous?)
;; ==> (wondrous? 27)
;; ==> (print prime?)
;; ==> (prime? 13)
;;
;;----------------------------------------------------------------------------------------
;; Grammar
;;
;; <definition> ::= (define procedure "<name>" (<symbol>*) <block>)
;; 
;; <block> ::= (block <id> begin <statement>*)
;;
;; <statement> ::= <block>
;;               | (if <exp> then <statement>)
;;               | (<var> <= <exp>)
;;               | (loop <exp> times <block>)
;;               | (loop at most <exp> times <block>)
;;               | (mu-loop <block>)
;;               | (quit block <id>)
;;               | (abort loop <id>)
;;               | (print <exp>*)
;;               | (load <filename>)
;;               | (load-quietly <filename>)
;; 
;; <exp> ::= <number>
;;         | <bool>
;;         | <var>
;;         | <string>
;;         | (<exp> <binop> <exp>)
;;         | (not <exp>)
;;         | (<exp> and <exp>)
;;         | (<exp> or <exp>)
;;         | (length <exp>)
;;         | (godel-number <exp>)
;;         | (<name> <exp>*)
;; 
;; <binop> ::= + | * | = | < | >
;; 
;; <var> ::= <symbol> | (cell <number>)
;; 
;; <bool> ::= YES | NO

(define-datatype definition definition?
  (func-def
    (name symbol?)
    (params (list-of symbol?))
    (init initial-value?)
    (block statement?)))

(define-datatype statement statement?
  (if-stmt
    (test expression?)
    (conseq statement?))
  (block-stmt
    (id number?)
    (body (list-of statement?)))
  (assign-stmt
    (ref reference?)
    (exp expression?))
  (loop-stmt
    (id number?)
    (exp expression?)
    (block statement?))
  (loop-at-most-stmt
    (id number?)
    (exp expression?)
    (block statement?))
  (mu-loop-stmt
    (id number?)
    (block statement?))
  (quit-stmt
    (id number?))
  (abort-stmt
    (id number?))
  (print-stmt
    (exps (list-of expression?)))
  (load-stmt
    (filename string?)
    (quietly? boolean?)))

(define-datatype reference reference?
  (var-ref
    (var symbol?))
  (cell-ref
    (id number?)
    (sym symbol?)))

(define-datatype expression expression?
  (num-exp
    (num number?))
  (bool-exp
    (bool boolean?))
  (str-exp
    (s string?))
  (var-exp
    (var symbol?))
  (cell-exp
    (id number?)
    (sym symbol?))
  (binop-exp
    (op symbol?)
    (exp1 expression?)
    (exp2 expression?))
  (not-exp
    (exp expression?))
  (and-exp
    (exp1 expression?)
    (exp2 expression?))
  (or-exp
    (exp1 expression?)
    (exp2 expression?))
  (length-exp
    (exp expression?))
  (godel-number-exp
    (exp expression?))
  (app-exp
    (name symbol?)
    (operands (list-of expression?))))
  
(define initial-value?
  (lambda (x) (or (number? x) (symbol? x))))

(define boolean-symbol?
  (lambda (x) (member x '(YES yes NO no))))

;;----------------------------------------------------------------------------------------
;; Parser

(define 1st car)
(define 2nd cadr)
(define 3rd caddr)
(define 4th cadddr)
(define 5th (lambda (x) (car (cddddr x))))
(define 6th (lambda (x) (cadr (cddddr x))))

(define cell-tag
  (lambda (id)
    (string->symbol (string-append "cell-" (number->string id)))))

(define block-tag
  (lambda (id)
    (string->symbol (string-append "block-" (number->string id)))))

(define loop-tag
  (lambda (id)
    (string->symbol (string-append "loop-" (number->string id)))))

(define ends-in-question-mark?
  (lambda (name)
    (equal? (string-ref name (- (string-length name) 1)) #\?)))

(define parse
  (lambda (x)
    (cond
      ((number? x) (num-exp x))
      ((string? x) (str-exp (replace-invalid-chars x)))
      ((boolean-symbol? x) (bool-exp (or (equal? x 'yes) (equal? x 'YES))))
      ((symbol? x) (var-exp x))
      ;; (cell <num>)
      ((cell? x) (cell-exp (2nd x) (cell-tag (2nd x))))
      ;; (<exp> <binop> <exp>)
      ((binop? x) (binop-exp (2nd x) (parse (1st x)) (parse (3rd x))))
      ;; (not <exp>)
      ((not? x) (not-exp (parse (2nd x))))
      ;; (<exp> and <exp>)
      ((and? x) (and-exp (parse (1st x)) (parse (3rd x))))
      ;; (<exp> or <exp>)
      ((or? x) (or-exp (parse (1st x)) (parse (3rd x))))
      ;; (define procedure "<name>" (<symbol>*) <block>)
      ((and (define? x) (block? (5th x)) (= 0 (2nd (5th x))))
       (func-def (string->symbol (3rd x))
		 (4th x)
		 (if (ends-in-question-mark? (3rd x)) 'NO 0)
		 (parse (5th x))))
      ;; (block <id> begin <statement>*)
      ((block? x) (block-stmt (2nd x) (map parse (cdddr x))))
      ;; (if <exp> then <statement>)
      ((if? x) (if-stmt (parse (2nd x)) (parse (4th x))))
      ;; (<var> <= <exp>)
      ((assign? x)
       (let ((var (1st x)))
	 (cond
	   ((symbol? var)
	    (assign-stmt (var-ref var) (parse (3rd x))))
	   ((cell? var)
	    (assign-stmt (cell-ref (2nd var) (cell-tag (2nd var))) (parse (3rd x))))
	   (else (eopl:error "bad assignment variable:" var)))))
      ;; (loop <exp> times <block>)
      ((and (loop? x) (block? (4th x)))
       (let ((id (2nd (4th x))))
	 (loop-stmt id (parse (2nd x)) (parse (4th x)))))
      ;; (loop at most <exp> times <block>)
      ((and (loop-at-most? x) (block? (6th x)))
       (let ((id (2nd (6th x))))
	 (loop-at-most-stmt id (parse (4th x)) (parse (6th x)))))
      ;; (mu-loop <block>)
      ((and (mu-loop? x) (block? (2nd x)))
       (let ((id (2nd (2nd x))))
	 (mu-loop-stmt id (parse (2nd x)))))
      ;; (quit block <id>)
      ((quit? x) (quit-stmt (3rd x)))
      ;; (abort loop <id>)
      ((abort? x) (abort-stmt (3rd x)))
      ;; (print <exp>*)
      ((print? x) (print-stmt (map parse (cdr x))))
      ;; (length <exp>)
      ((length? x) (length-exp (parse (2nd x))))
      ;; (godel-number <exp>)
      ((godel-number? x) (godel-number-exp (parse (2nd x))))
      ;; (load <filename>)
      ((load? x) (load-stmt (2nd x) #f))
      ;; (load-quietly <filename>)
      ((load-quietly? x) (load-stmt (2nd x) #t))
      ;; (<name> <exp>*)
      ((application? x) (app-exp (1st x) (map parse (cdr x))))
      (else (eopl:error "bad concrete syntax:" x)))))

(define matches-pattern?
  (lambda (pattern)
    (lambda (x)
      (cond
        ((and (null? x) (null? pattern)) #t)
	((null? pattern) #f)
	((equal? (car pattern) '...) #t)
	((or (null? x) (not (list? x))) #f)
	((equal? (car pattern) '_) ((matches-pattern? (cdr pattern)) (cdr x)))
	((and (list? (car pattern)) (member (car x) (car pattern)))
	 ((matches-pattern? (cdr pattern)) (cdr x)))
	((equal? (car pattern) (car x)) ((matches-pattern? (cdr pattern)) (cdr x)))
	(else #f)))))

(define define? (matches-pattern? '(define procedure _ _ _)))
(define block? (matches-pattern? '(block _ begin ...)))
(define if? (matches-pattern? '(if _ then _)))
(define assign? (matches-pattern? '(_ <= _)))
(define loop? (matches-pattern? '(loop _ times _)))
(define loop-at-most? (matches-pattern? '(loop at most _ times _)))
(define mu-loop? (matches-pattern? '(mu-loop _)))
(define quit? (matches-pattern? '(quit block _)))
(define abort? (matches-pattern? '(abort loop _)))
(define not? (matches-pattern? '(not _)))
(define and? (matches-pattern? '(_ and _)))
(define or? (matches-pattern? '(_ or _)))
(define binop? (matches-pattern? '(_ (+ * = > <) _)))
(define cell? (matches-pattern? '(cell _)))
(define print? (matches-pattern? '(print ...)))
(define length? (matches-pattern? '(length _)))
(define godel-number? (matches-pattern? '(godel-number _)))
(define load? (matches-pattern? '(load _)))
(define load-quietly? (matches-pattern? '(load-quietly _)))

(define keywords
  '(if define block loop mu-loop quit abort output cell
     print length godel-number load load-quietly))

(define application?
  (lambda (x)
    (and (list? x)
	 (>= (length x) 1)
	 (not (member (car x) keywords)))))

;;----------------------------------------------------------------------------------------
;; Code formatting

(define format-code
  (lambda (code)
    (cond
      ((definition? code)
       (cases definition code
	 (func-def (name params init block)
	   (concat
	     "DEFINE PROCEDURE ''" (uppercase name) "'' "
	     (format-params params) ":\n" (format-code block)))))
      ((reference? code)
       (cases reference code
	 (var-ref (var) (uppercase var))
	 (cell-ref (id sym) (concat "CELL(" id ")"))))
      ((statement? code)
       (cases statement code
	 (if-stmt (test conseq)
	   (concat "IF " (format-code test) ", THEN:\n" (format-code conseq)))
	 (block-stmt (id body)
	   (concat
	     "BLOCK " id ": BEGIN\n"
	     (apply concat (map format-code body))
	     (if (= id 0)
		 (concat "BLOCK 0: END.")
		 (concat "BLOCK " id ": END;\n"))))
	 (assign-stmt (ref exp)
	   (concat (format-code ref) " <= " (format-code exp) ";\n"))
	 (loop-stmt (id exp block)
	   (concat "LOOP " (format-code exp) " TIMES:\n" (format-code block)))
	 (loop-at-most-stmt (id exp block)
	   (concat "LOOP AT MOST " (format-code exp) " TIMES:\n" (format-code block)))
	 (mu-loop-stmt (id block)
	   (concat "MU-LOOP:\n" (format-code block)))
	 (quit-stmt (id) (concat "QUIT BLOCK " id ";\n"))
	 (abort-stmt (id) (concat "ABORT LOOP " id ";\n"))
	 (print-stmt (exps)
	   (if (null? exps)
	     "PRINT;\n"
	     (concat "PRINT " (join ", " (map format-code exps)) ";\n")))
	 (load-stmt (filename quietly?)
	   (concat "LOAD ''" filename "''\n"))))
      ((expression? code)
       (cases expression code
	 (num-exp (num) (number->string num))
	 (bool-exp (bool) (if bool "YES" "NO"))
	 (str-exp (s) (concat "''" (uppercase s) "''"))
	 (var-exp (var) (uppercase var))
	 (cell-exp (id sym) (concat "CELL(" id ")"))
	 (binop-exp (op exp1 exp2)
	   (cond
	     ((not (equal? op '*))
	      (concat (format-code exp1) " " op " " (format-code exp2)))
	     ((and (plus-exp? exp1) (plus-exp? exp2))
	      (concat "(" (format-code exp1) ") × (" (format-code exp2) ")"))
	     ((plus-exp? exp1)
	      (concat "(" (format-code exp1) ") × " (format-code exp2)))
	     ((plus-exp? exp2)
	      (concat (format-code exp1) " × (" (format-code exp2) ")"))
	     (else (concat (format-code exp1) " × " (format-code exp2)))))
	 (not-exp (exp)
	   (concat "NOT " (format-code exp)))
	 (and-exp (exp1 exp2)
	   (concat "{" (format-code exp1) " AND " (format-code exp2) "}"))
	 (or-exp (exp1 exp2)
	   (concat "{" (format-code exp1) " OR " (format-code exp2) "}"))
	 (length-exp (exp)
	   (concat "LENGTH [" (format-code exp) "]"))
	 (godel-number-exp (exp)
	   (concat "GODEL-NUMBER [" (format-code exp) "]"))
	 (app-exp (name operands)
	   (concat (uppercase name) " " (format-operands operands)))))
      (else (eopl:error "format-code: bad abstract syntax:" code)))))

(define format-params
  (lambda (params)
    (concat "[" (join ", " (map uppercase params)) "]")))

(define format-operands
  (lambda (args)
    (concat "[" (join ", " (map format-code args)) "]")))

(define plus-exp?
  (lambda (exp)
    (cases expression exp
      (binop-exp (op exp1 exp2) (equal? op '+))
      (else #f))))

(define uppercase
  (lambda (s)
    (cond
      ((symbol? s) (uppercase (symbol->string s)))
      ((string? s) (list->string (map char-upcase (string->list s))))
      (else s))))

(define uppercase-symbol
  (lambda (sym)
    (string->symbol (uppercase (symbol->string sym)))))

(define concat
  (lambda args
    (join ""
	  (map (lambda (x)
		 (cond
		  ((symbol? x) (symbol->string x))
		  ((number? x) (number->string x))
		  (else x)))
	       args))))

(define join
  (lambda (sep l)
    (if (null? l)
      ""
      (let ((s (apply string-append (map (lambda (x) (string-append x sep)) l))))
	(substring s 0 (- (string-length s) (string-length sep)))))))

(define split
  (lambda (s)
    (let ((i (find-char #\newline s 0)))
      (if (= i -1)
	(list s)
	(cons (substring s 0 i) (split (substring s (+ i 1) (string-length s))))))))

(define find-char
  (lambda (char s i)
    (cond
      ((>= i (string-length s)) -1)
      ((char=? (string-ref s i) char) i)
      (else (find-char char s (+ i 1))))))

(define print-code
  (lambda (code)
    (newline)
    (print-indented 0 (split (format-code code)))))

(define print-indented
  (lambda (level lines)
    (cond
      ((null? lines) 'ok)
      ((starts-with? "BLOCK" (car lines))
       (if (ends-with? "BEGIN" (car lines))
	 (begin
	   (display (indent level))
	   (display (car lines))
	   (newline)
	   (print-indented (+ level 1) (cdr lines)))
	 (begin
	   (display (indent (- level 1)))
	   (display (car lines))
	   (newline)
	   (print-indented (- level 1) (cdr lines)))))
      (else (display (indent level))
	    (display (car lines))
	    (newline)
	    (print-indented level (cdr lines))))))

(define indent
  (lambda (level)
    (make-string (* 10 level) #\space)))

(define starts-with?
  (lambda (prefix line)
    (let ((len (string-length prefix)))
      (and (<= len (string-length line))
	   (string=? (substring line 0 len) prefix)))))

(define ends-with?
  (lambda (suffix line)
    (let ((len (string-length suffix))
	  (end (string-length line)))
      (and (<= len end)
	   (string=? (substring line (- end len) end) suffix)))))

(define replace-newlines
  (lambda (s)
    (list->string
      (map (lambda (x) (if (char=? x #\newline) #\space x))
	   (string->list s)))))

(define replace-substrings
  (lambda (old new s)
    (let ((i (find-substring old s 0)))
      (if (= i -1)
	s
	(let ((head (substring s 0 i))
	      (tail (substring s (+ i (string-length old)) (string-length s))))
	  (string-append head new (replace-substrings old new tail)))))))

(define find-substring
  (lambda (sub s i)
    (cond
      ((> i (- (string-length s) (string-length sub))) -1)
      ((string=? (substring s i (+ i (string-length sub))) sub) i)
      (else (find-substring sub s (+ i 1))))))

;; for top-level use only
(define program-string
  (lambda (program)
    (replace-newlines (format-code (parse program)))))

(define code-string
  (lambda (code)
    ;; count the special symbols "<=" and "×" as single characters
    (replace-substrings "<=" "#"
      (replace-substrings "×" "*"
	(replace-newlines (format-code code))))))

(define code-length
  (lambda (code)
    (string-length (code-string code))))

(define godel-number
  (lambda (code)
    (let ((s (code-string code)))
      (string->number (join "" (map number->string (map char->codenum (string->list s))))))))

;; # is used in place of <=
;; * is used in place of × (integer->char 215)
(define all-chars "ABCDEFGHIJKLMNOPQRSTUVWXYZ+*0123456789#=<>()[]{}-'?:;,. ")
(define all-chars-list (string->list all-chars))

(define char->codenum
  (lambda (char)
    (+ 900 (+ 1 (find-char char all-chars 0)))))

(define replace-invalid-chars
  (lambda (s)
    (list->string (map (lambda (x) (if (member x all-chars-list) x #\?))
		       (map char-upcase (string->list s))))))

;;----------------------------------------------------------------------------------------
;; Interpreter

(define toplevel-env 'undefined)

(define start
  (lambda ()
    (display "Welcome to the SLC FlooP interpreter\n\n")
    (set! toplevel-env (make-init-env))
    (read-eval-print)))

(define restart
  (lambda ()
    (display "Restarting...\n")
    (if (equal? toplevel-env 'undefined)
      (set! toplevel-env (make-init-env))
      'ignore)
    (read-eval-print)))

(define read-eval-print
  (lambda ()
    (display "==> ")
    (let ((input (read)))
      (if (equal? input 'exit)
	  'Goodbye!
	  (m (parse input) toplevel-env (make-empty-env) REP-k)))))

(define REP-k
  (lambda (v)
    (if (not (equal? v 'ok))
      (begin
	(safe-display v)
	(newline))
      'ignore)
    (read-eval-print)))

(define procedure-symbol
  (lambda (proc-obj)
    (string-append "<PROCEDURE:" (uppercase (2nd proc-obj)) ">")))

(define safe-display
  (lambda (x)
    (cond
      ((procedure-object? x) (display (procedure-symbol x)))
      ((builtin-object? x) (display (builtin-symbol x)))
      (else (display x)))))

(define report-error
  (lambda args
    (display "Error: ")
    (for-each
      (lambda (x) (safe-display x) (display " "))
      args)
    (newline)
    (REP-k 'ok)))

;; (procedure <name> <scheme_procedure> <parse_tree>)
(define procedure-object? (matches-pattern? '(procedure _ _ _)))

(define make-procedure-object
  (lambda (code env)
    (cases definition code
      (func-def (name params init block)
	(let ((implementation
		(lambda (vals k-env k2)
		  (if (not (= (length vals) (length params)))
		    (report-error name "expects" (length params)
				  (if (= (length params) 1) "value" "values"))
		    (let ((extended-env (extend (cons 'output params) (cons init vals) env)))
		      (m block extended-env k-env
			 (lambda (v)
			   (lookup-value 'output extended-env k2))))))))
	  (list 'procedure name implementation code))))))

(define m
  (lambda (code env k-env k)
    (cond
      ((definition? code)
       (cases definition code
	 (func-def (name params init block)
	   (let ((procedure (make-procedure-object code env)))
	     (set! toplevel-env (extend (list name) (list procedure) env))
	     (k 'ok)))))
      ((statement? code)
       (cases statement code
	 (if-stmt (test conseq)
	   (m test env k-env
	     (lambda (v)
	       (if (equal? v 'YES)
		 (m conseq env k-env k)
		 (k 'ok)))))
	 (block-stmt (id body)
	   (let ((extended-k-env (extend (list (block-tag id)) (list k) k-env)))
	     (m-sequence body env extended-k-env k)))
	 (assign-stmt (ref exp)
	   (m exp env k-env
	     (lambda (v)
	       (m ref env k-env
		 (lambda (r)
		   (setref! r v)
		   (k 'ok))))))
	 (loop-stmt (id exp block)
	   (m exp env k-env
	     (lambda (limit)
	       (if (number? limit)
		 (let ((extended-k-env (extend (list (loop-tag id)) (list k) k-env)))
		   (run-bounded-loop limit block env extended-k-env k))
		 (report-error "loop limit is not a number")))))
	 (loop-at-most-stmt (id exp block)
	   (m exp env k-env
	     (lambda (limit)
	       (if (number? limit)
		 (let ((extended-k-env (extend (list (loop-tag id)) (list k) k-env)))
		   (run-bounded-loop limit block env extended-k-env k))
		 (report-error "loop limit is not a number")))))
	 (mu-loop-stmt (id block)
	   (let ((extended-k-env (extend (list (loop-tag id)) (list k) k-env)))
	     (run-free-loop block env extended-k-env k)))
	 (quit-stmt (id)
	   (lookup-ref (block-tag id) k-env
	     (lambda (v) ((deref v) 'ok))
	     (lambda () (report-error "not inside block" id))))
	 (abort-stmt (id)
	   (lookup-ref (loop-tag id) k-env
	     (lambda (v) ((deref v) 'ok))
	     (lambda () (report-error "not inside loop" id))))
	 (print-stmt (exps) (run-print exps env k-env k))
	 (load-stmt (filename quietly?)
	   (set! toplevel-env (make-init-env))
	   (load-loop (open-input-file filename) quietly? k-env k))))
      ((reference? code)
       (let ((sym (cases reference code
		    (var-ref (var) var)
		    (cell-ref (id sym) sym))))
	 (lookup-ref sym env k
	   (lambda ()
	     (let ((ref (newref 'undefined)))
              (let ((new-frame (list (cons sym (first-frame-vars env))
                                     (cons ref (first-frame-refs env)))))
		(setref! (car env) new-frame)
		(k ref)))))))
      ((expression? code)
       (cases expression code
	 (num-exp (num)
	   (if (and (integer? num) (>= num 0))
	       (k num)
	       (report-error num "is not a natural number")))
	 (bool-exp (bool) (k (if bool 'YES 'NO)))
	 (str-exp (s) (k s))
	 (var-exp (var)
	   (if (equal? var 'environment)
	     (k (printable-environment env))
	     (lookup-value var env k)))
	 (cell-exp (id sym) (lookup-value sym env k))
	 (binop-exp (op exp1 exp2)
	   (m exp1 env k-env
	     (lambda (v1)
	       (m exp2 env k-env
		 (lambda (v2)
		   (cond
		     ((equal? op '=) (k (if (equal? v1 v2) 'YES 'NO)))
		     ((not (number? v1)) (report-error v1 "is not a number"))
		     ((not (number? v2)) (report-error v2 "is not a number"))
		     ((equal? op '+) (k (+ v1 v2)))
		     ((equal? op '*) (k (* v1 v2)))
		     ((equal? op '>) (k (if (> v1 v2) 'YES 'NO)))
		     ((equal? op '<) (k (if (< v1 v2) 'YES 'NO)))
		     (else (eopl:error "bad binary operator:" op))))))))
	 (not-exp (exp)
	   (m exp env k-env
	     (lambda (v)
	       (if (equal? v 'NO)
		 (k 'YES)
		 (k 'NO)))))
	 (and-exp (exp1 exp2)
	   (m exp1 env k-env
	     (lambda (v1)
	       (if (equal? v1 'NO)
		 (k 'NO)
		 (m exp2 env k-env k)))))
	 (or-exp (exp1 exp2)
	   (m exp1 env k-env
	     (lambda (v1)
	       (if (equal? v1 'NO)
		 (m exp2 env k-env k)
		 (k v1)))))
	 (length-exp (exp)
	   (m exp env k-env
	     (lambda (v)
	       (cond
		 ((procedure-object? v) (k (code-length (4th v))))
		 ((builtin-object? v)
		  (if (eq? (4th v) 'none)
		    (report-error "no code available for" (2nd v))
		    (k (code-length (4th v)))))
		 ((number? v) (k (count-digits v)))
		 ((string? v) (k (string-length v)))
		 ((boolean-symbol? v) (k (string-length (symbol->string v))))
		 (else (k 0))))))
	 (godel-number-exp (exp)
	   (m exp env k-env
	     (lambda (v)
	       (cond
		 ((procedure-object? v) (k (godel-number (4th v))))
		 ((builtin-object? v)
		  (if (eq? (4th v) 'none)
		    (report-error "no code available for" (2nd v))
		    (k (godel-number (4th v)))))
		 (else (report-error v "is not a procedure"))))))
	 (app-exp (name operands)
	   (lookup-value name env
	     (lambda (v)
	       (if (not (or (procedure-object? v) (builtin-object? v)))
		 (report-error name "is not a procedure")
		 (m* operands env k-env
		     (lambda (vals)
		       (let ((procedure (3rd v)))
			 (procedure vals k-env k))))))))))
      (else (eopl:error "m: bad abstract syntax:" code)))))

(define m*
  (lambda (exps env k-env k)
    (cond
      ((null? exps) (k '()))
      (else (m (car exps) env k-env
               (lambda (v1)
		 (if (not (and (integer? v1) (>= v1 0)))
		   (report-error v1 "is not a natural number")
		   (m* (cdr exps) env k-env
		       (lambda (v2)
			 (k (cons v1 v2)))))))))))

(define m-sequence
  (lambda (statements env k-env k)
    (if (null? statements)
      (k 'ok)
      (m (car statements) env k-env
	(lambda (v)
	  (m-sequence (cdr statements) env k-env k))))))

(define run-bounded-loop
  (lambda (counter block env k-env k)
    (if (<= counter 0)
      (k 'ok)
      (m block env k-env
	(lambda (v) (run-bounded-loop (- counter 1) block env k-env k))))))

(define run-free-loop
  (lambda (block env k-env k)
    (m block env k-env
      (lambda (v) (run-free-loop block env k-env k)))))

(define run-print
  (lambda (exps env k-env k)
    (if (null? exps)
      (begin
	(newline)
	(k 'ok))
      (m (car exps) env k-env
	(lambda (v)
	  (cond
	    ((procedure-object? v) (print-code (4th v)))
	    ((builtin-object? v)
	     (if (eq? (4th v) 'none)
	       (report-error "no code available for" (2nd v))
	       (print-code (4th v))))
	    (else (display v) (display " ")))
	  (run-print (cdr exps) env k-env k))))))

(define count-digits
  (lambda (num)
    (string-length (number->string num))))

(define load-loop
  (lambda (port quietly? k-env k)
    (let ((input (read port)))
      (if (eof-object? input)
	(begin
	  (close-input-port port)
	  (if (not quietly?)
	    (newline)
            'ignore)
	  (k 'ok))
	(let ((code (parse input)))
	  (m code toplevel-env k-env
	     (lambda (v)
	       (if (not quietly?)
		 (print-code code)
                 'ignore)
	       (load-loop port quietly? k-env k))))))))

;;----------------------------------------------------------------------------------------
;; Builtins

(define minus-code
  '(define procedure "minus" (m n)
     (block 0 begin
	    (if (m < n) then
		(quit block 0))
	    (loop at most (m + 1) times
		  (block 1 begin
			 (if ((output + n) = m) then
			     (abort loop 1))
			 (output <= (output + 1)))))))

(define remainder-code
  '(define procedure "remainder" (m n)
     (block 0 begin
	    (if (n = 0) then
		(quit block 0))
	    (output <= m)
	    (loop at most m times
		  (block 1 begin
			 (if (output < n) then
			     (quit block 0))
			 (output <= (minus output n)))))))

(define quotient-code
  '(define procedure "quotient" (m n)
     (block 0 begin
	    (if (n = 0) then
		(quit block 0))
	    ((cell 0) <= m)
	    (output <= 0)
	    (loop at most m times
		  (block 1 begin
			 (if ((cell 0) < n) then
			     (quit block 0))
			 ((cell 0) <= (minus (cell 0) n))
			 (output <= (output + 1)))))))

(define power-code
  '(define procedure "power" (m n)
     (block 0 begin
            (output <= 1)
            (loop n times
                  (block 1 begin
                         (output <= (output * m)))))))

;; (builtin <name> <scheme_procedure>)
(define builtin-object? (matches-pattern? '(builtin _ _ _)))

(define builtin-symbol
  (lambda (builtin)
    (string-append "<BUILTIN:" (uppercase (2nd builtin)) ">")))

;; to prevent builtin code from being viewable, specify 'none for code parameter
(define builtin-operations
  (lambda ()
    (list (make-builtin 'minus 2 minus-code ;; or 'none
	    (lambda (vals k) (k (max 0 (- (1st vals) (2nd vals))))))
	  (make-builtin 'quotient 2 quotient-code
	    (lambda (vals k) (k (quotient (1st vals) (2nd vals)))))
	  (make-builtin 'remainder 2 remainder-code
	    (lambda (vals k) (k (remainder (1st vals) (2nd vals)))))
          (make-builtin 'power 2 power-code
            (lambda (vals k) (k (expt (1st vals) (2nd vals)))))
	  )))

(define make-builtin
  (lambda (name num-params code proc)
    (list name
	  (lambda (vals k-env k)
	    (if (not (= (length vals) num-params))
		(report-error name "expects" num-params (if (= num-params 1) "value" "values"))
		(proc vals k)))
	  (if (eq? code 'none) 'none (parse code)))))

;;(define make-init-env
;;  (lambda ()
;;    (extend '() '() (make-empty-env))))

(define make-init-env
  (lambda ()
    (let ((names (map 1st (builtin-operations)))
	  (builtins (map (lambda (b) (cons 'builtin b)) (builtin-operations))))
      (extend names builtins (make-empty-env)))))

(define printable-environment
  (lambda (env)
    (apply append
      (map (lambda (frame)
	     (map (lambda (var ref)
		    (let ((val (deref ref)))
		      (cond
		        ((procedure-object? val) (procedure-symbol val))
			((builtin-object? val) (builtin-symbol val))
			(else (list var '= val)))))
		  (1st frame)
		  (2nd frame)))
	   (map deref env)))))

;;----------------------------------------------------------------------------------------
;; Environments

;; environments are represented as lists of references to frames

(define make-empty-env
  (lambda () '()))

(define extend
  (lambda (new-syms new-vals old-env)
    (let ((new-refs (map newref new-vals)))
      (let ((frame (list new-syms new-refs)))
        (cons (newref frame) old-env)))))

(define first-frame-vars
  (lambda (env)
    (car (deref (car env)))))

(define first-frame-refs
  (lambda (env)
    (cadr (deref (car env)))))

(define first-frame-vals
  (lambda (env)
    (map deref (first-frame-refs env))))

(define retrieve
  (lambda (var frame-vars frame-refs)
    (cond
      ((eq? (car frame-vars) var) (car frame-refs))
      (else (retrieve var (cdr frame-vars) (cdr frame-refs))))))

(define lookup-ref
  (lambda (var env k fail)
    (cond
      ((null? env) (fail))
      ((member var (first-frame-vars env))
       (k (retrieve var (first-frame-vars env) (first-frame-refs env))))
      (else (lookup-ref var (cdr env) k fail)))))

(define lookup-value
  (lambda (var env k)
    (lookup-ref var env
      (lambda (v) (k (deref v)))
      (lambda () (report-error var "is undefined")))))

;; references are represented as 1-element vectors

(define newref
  (lambda (x)
    (vector x)))

(define deref
  (lambda (ref)
    (if (vector? ref)
      (vector-ref ref 0)
      ref)))

(define setref!
  (lambda (ref new-val)
    (vector-set! ref 0 new-val)))