(* File: {PHYLUM}<DESRIVIERES>NLISP>SM-NORMALISE in Gacha 10. *)

(* Last edited: Nov. 1, 1983 by Jim des Rivieres  *)

(* Uses: {PHYLUM}<LISP>LIBRARY>CMLSPECIALFORMS.DCOM *)

(* Processor for a non-reflective, non-meta-structural
   LISP done as a bloody big prog.
*)

(globalvars lambda-closure if-closure gset-closure let-closure
     global-env)

(defun 1.9-lisp (stream)
 (do (ersetq 
 (prog (exp env cont result proc! unargs message culprit
        let-defs let-body let-temp)

  read-normalise-print
     (setq exp (prompt&read stream))
     (setq env global-env)
     (setq cont (make-cont 'creply! exp '? '?))
     (go normalise)

  normalise
     (* Uses exp, env cont. *)
     (if (atom? exp) then
         (setq result (binding (extract-atom exp) env))
         (if (eq result 'not.found) then
             (setq culprit exp)
             (setq message "unbound variable")
             (go diagnose-error))
         (go continue))
     (if (pair? exp) then
         (setq cont (make-cont 'cproc! (pcdr exp) env cont))
         (setq exp (pcar exp))
         (go normalise))
     (if (rail? exp) then
         (go normalise-rail))
     (* Otherwise exp is self-normalising. *)
     (setq result exp)
     (go continue)

  normalise-rail
     (if (empty? exp) then
         (setq result (rcons0))
         (go continue))
     (setq cont (make-cont 'cfirst! (rest exp) env cont))
     (setq exp (first exp))
     (go normalise)

  cproc!
     (setq proc! result)
     (if (not (closure? proc!)) then
         (setq culprit exp)
         (setq message "not reducible")
         (go diagnose-error))
     (setq unargs (field1 cont))
     (setq env (field2 cont))
     (setq cont (field3 cont))
     (if (lambda? proc!) then
         (if (or (not (rail? unargs))
                 (not (equal (rlength unargs) 2))) then
             (setq culprit (pcons lambda-closure unargs))
             (setq message "mangled lambda expression")
             (go diagnose-error))
         (setq result 
           (ccons env
                  (first unargs)
                  (second unargs)))
         (go continue))
     (if (if? proc!) then
         (if (or (not (rail? unargs))
                 (not (equal (rlength unargs) 3))) then
             (setq culprit (pcons if-closure unargs))
             (setq message "mangled if expression")
             (go diagnose-error))
         (setq exp (first unargs))
         (setq cont (make-cont 'cif! (rest unargs) env cont))
         (go normalise))
     (if (gset? proc!) then
         (if (or (not (rail? unargs))
                 (not (equal (rlength unargs) 2))
                 (not (atom? (first unargs)))) then
             (setq culprit (pcons gset-closure unargs))
             (setq message "mangled gset expression")
             (go diagnose-error))
         (setq exp (second unargs))
         (setq cont (make-cont 'cgset! (first unargs) env cont))
         (go normalise))
     (if (let? proc!) then
         (go parse-let))

     (* Otherwise just a simple procedure. *)
     (setq exp unargs)
     (setq cont (make-cont 'cargs! proc! '? cont))
     (go normalise)

  parse-let
     (if (or (not (rail? unargs))
             (not (equal (rlength unargs) 2))) then
         (go let-error))
     (setq let-body (second unargs))
     (setq let-defs (first unargs))
     (if (not (rail? let-defs)) then
         (go let-error))
     (setq let-temp (unzip-let let-defs))
     (if (equal let-temp 'bad.let.def) then
         (go let-error))
     (setq exp
        (pcons (pcons lambda-closure
                      (prep (car let-temp) (prep let-body (rcons0))))
               (cdr let-temp)))
     (go normalise)

  let-error
     (setq culprit (pcons let-closure unargs)) 
     (setq message "mangled let expression")
     (go diagnose-error)

  cargs!
     (setq proc! (field1 cont))
     (setq cont (field3 cont))
     (setq env 
         (bind (pattern proc!)
               result
               (environment proc!)))
     (if (eq env 'no.match) then
         (setq culprit (pcons proc! result))
         (setq message "wrong number of arguments")
         (go diagnose-error))
     (if (primitive? proc!) then
         (setq result (do-primitive proc! result))
         (if (neq result 'error.in.primitive) then
             (go continue))
         (setq culprit (pcons proc! result))
         (setq message "error in a primitive")
         (go diagnose-error))
     (setq exp (body proc!))
     (go normalise)

  cfirst!
     (setq exp (field1 cont))
     (setq env (field2 cont))
     (setq cont (make-cont 'crest! result '? (field3 cont)))
     (go normalise-rail)

  crest!
     (setq result (prep (field1 cont) result))
     (setq cont (field3 cont))
     (go continue)

  cif!
     (setq exp (field1 cont))
     (setq env (field2 cont))
     (setq cont (field3 cont))
     (if (eq result 't) then
         (setq exp (first exp))
         (go normalise))
     (if (eq result 'nil) then
         (setq exp (second exp))
         (go normalise))
     (setq culprit (pcons if-closure (prep result exp)))
     (setq message "if expects a boolean")
     (go diagnose-error)

  cgset!
     (setq exp (field1 cont))
     (setq cont (field3 cont))
     (global-rebind exp result)
     (setq result result)
     (go continue)
     
  creply!
     (prompt&print result stream)
     (go read-normalise-print)
 
  continue
     (selectq (continuation-type cont)
        (cproc! (go cproc!))
        (cargs! (go cargs!))
        (cfirst! (go cfirst!))
        (crest! (go crest!))
        (cif! (go cif!))
        (creply! (go creply!))
        (cgset! (go cgset!))
        (shouldnt "unrecognized continuation"))

  diagnose-error
     (printout stream "*** " message "." t)
     (printout stream "Hint: " .ppv (export culprit) t)
     (printout stream t "Reset." t)
     (setq message nil)
     (setq culprit nil)
     (go read-normalise-print) 
)) ))

(defun unzip-let (rail)
   (if (empty? rail) then
       (cons (rcons0) (rcons0))
    else
       (let ((f (first rail))
             (x (unzip-let (rest rail))))
          (cond ((equal x 'bad.let.def) x)
                ((not (rail? f)) 'bad.let.def)
                ((empty? f) 'bad.let.def)
                ((empty? (rest f)) 'bad.let.def)
                ((not (empty? (rest (rest f)))) 'bad.let.def)
                (t (cons (prep (first f) (car x))
                         (prep (second f) (cdr x))) )))))


(defun make-cont (type f1 f2 f3)
   (list type f1 f2 f3))
(defun continuation-type (cont) (car cont))
(defun field1 (cont) (cadr cont))
(defun field2 (cont) (caddr cont))
(defun field3 (cont) (cadddr cont))

STOP