;;; June 6, 1984
;;; This implementation of 3-lisp in 3-lisp is the one
;;; presented in the implementation paper [des Rivieres & Smith 84]
;;; This program does work, albeit slowly.  The examples which it 
;;; handled successfully were:
;;;
;;;     100
;;;     (+ 2 2)
;;;     (lambda simple [x] x)
;;;     ((lambda simple [x] x) 10)
;;;     (cond [$f 1] [(= 2 2) 4])
;;;     ((lambda reflect [a e c] (c '3)))
;;;     (set z 99)
;;; and (block 1 2)
;;;
;;; (and boy, was it slow!)

(define 3-LISP
  (lambda simple []
    (&&read-normalise-print (initial-tower 2) 1 global) ))
(define &&READ-NORMALISE-PRINT
  (lambda simple [state level env]
    (&&normalise state (:prompt&read level) env
      (make-reply-continuation level env) )))
(define &&REPLY-CONTINUATION
  (lambda simple [state result level env]
    (block 
      (:prompt&reply result level)
      (&&read-normalise-print state level env) )))
(define &&NORMALISE
  (lambda simple [state exp env cont]
    (block (print exp primary-stream) (newline primary-stream)
    (cond [(normal exp) (&&call state cont exp)]
          [(atom exp) (&&call state cont (binding exp env))]
          [(rail exp) (&&normalise-rail state exp env cont)]
          [(pair exp) (&&reduce state (car exp)
                         (cdr exp) env cont )]))) )
(define &&REDUCE
  (lambda simple [state proc args env cont]
    (&&normalise state proc env
      (make-proc-continuation proc args env cont) )))
(define &&PROC-CONTINUATION
  (lambda simple [state proc! proc args env cont]
    (if (reflective proc!)
        (&&call state \(de-reflect proc!) args env cont)
        (&&normalise state args env
          (make-args-continuation proc! proc args env cont) ))))
(define &&ARGS-CONTINUATION
  (lambda simple [state args! proc! proc args env cont]
    (if (or (primitive proc!) (kernel-utility proc!))
        (&&call state cont ^(\proc! . \args!))
        (&&expand-closure state proc! args! cont) )))
(define &&EXPAND-CLOSURE
  (lambda simple [state proc! args! cont]
    (cond [(and (= (kernel-primary-type proc!) 'normalise)
                (plausible-arguments-to-normalise args!))
           (&&normalise (shift-down cont state) 
              \(1st args!) \(2nd args!) \(3rd args!))]
          [(and (kernel-continuation-closure proc!)
                (plausible-arguments-to-a-continuation args!))
           (&&call-continuation (shift-down cont state) 
              \proc! \(1st args!))]
          [$t (&&normalise state (body proc!)
                (bind (pattern proc!) args! (environment proc!))
                cont )]))) 
(define &&NORMALISE-RAIL
  (lambda simple [state rail env cont]
    (if (empty rail)
        (&&call state cont (rcons))
        (&&normalise state (1st rail) env
          (make-first-continuation rail env cont) ))))
(define &&FIRST-CONTINUATION
  (lambda simple [state first! rail env cont]
    (&&normalise-rail state (rest rail) env
      (make-rest-continuation first! rail env cont) )))
(define &&REST-CONTINUATION
  (lambda simple [state rest! first! rail env cont]
    (&&call state cont (prep first! rest!)) ))
(define &&LAMBDA
  (lambda simple [state [kind pattern body] env cont]
     (&&call state cont (ccons kind ^env pattern body)) ))
(define &&IF
  (lambda simple [state [premise c1 c2] env cont]
    (&&normalise state premise env
      (make-if-continuation premise c1 c2 env cont) )))
(define &&IF-CONTINUATION
  (lambda simple [state premise! premise c1 c2 env cont]
     (&&normalise state (ef \premise! c1 c2) env cont) )) 
(define &&CALL
  (lambda simple x
    (let [[state (1st x)] [f (2nd x)] [a (rest (rest x))]]
      (cond [(kernel-primary-closure ^f)
             (&&call-primary state f a)]
            [(and (kernel-continuation-closure ^f)
                  (= (length a) 1))
             (&&call-continuation state f (1st a))]
            [(or (primitive ^f) (kernel-utility ^f))
             (&&call (shift-up state)
               (reify-continuation state) ^(f . a))]
            [$t  
             (&&expand-closure (shift-up state)
               ^f ^a (reify-continuation state) )])))) 
(define &&CALL-PRIMARY
  (lambda simple [state f a]
    (select (kernel-primary-type ^f)
      ['normalise
          (&&normalise state (1st a) (2nd a) (3rd a))]
      ['normalise-rail
          (&&normalise-rail state (1st a) (2nd a) (3rd a))]
      ['reduce
          (&&reduce state (1st a) (2nd a) (3rd a) (4th a))]
      ['read-normalise-print
          (&&read-normalise-print state (1st a) (2nd a))]
      ['if
          (&&if state (1st a) (2nd a) (3rd a))]
      ['lambda
          (&&lambda state (1st a) (2nd a) (3rd a)) ])))
(define &&CALL-CONTINUATION
  (lambda simple [state f arg]
    (select (kernel-continuation-type ^f)
      ['proc  (&&proc-continuation state arg
                   (extract 'proc f) (extract 'args f)
                   (extract 'env f) (extract 'cont f))]
      ['args  (&&args-continuation state arg
                   (extract 'proc! f) (extract 'proc f)
                   (extract 'args f) (extract 'env f)
                   (extract 'cont f))]
      ['first (&&first-continuation state arg
                   (extract 'rail f) (extract 'env f)
                   (extract 'cont f))]
      ['rest  (&&rest-continuation state arg
                   (extract 'first! f) (extract 'rail f)
                   (extract 'env f) (extract 'cont f))]
      ['reply (&&reply-continuation state arg
                   (extract 'level f) (extract 'env f))]
      ['if    (&&if-continuation state arg
                   (extract 'premise f) (extract 'c1 f)
                   (extract 'c2 f) (extract 'env f)
                   (extract 'cont f) )])))
(define MAKE-PROC-CONTINUATION
  (lambda simple [proc args env cont]
    \(ccons 'simple ^(bind '[proc args env cont reduce]
                          ^[proc args env cont reduce] global)
        '[proc!]
        '(if (reflective proc!)
             (\(de-reflect proc!) args env cont)
             (normalise args env
                (lambda [args!]
                   (if (primitive proc!)
                       (cont ^(\proc! . \args!))
                       (normalise (body proc!)
                                  (bind (pattern proc!) args!
                                        (environment proc!))
                                  cont ))))) )))
(define MAKE-ARGS-CONTINUATION
  (lambda simple [proc! proc args env cont]
    \(ccons 'simple ^(bind '[proc! proc args env cont reduce]
                          ^[proc! proc args env cont reduce] global)
        '[args!]
        '(if (primitive proc!)
             (cont ^(\proc! . \args!))
             (normalise (body proc!)
                        (bind (pattern proc!) args!
                              (environment proc!))
                        cont )) )))
(define MAKE-FIRST-CONTINUATION
  (lambda simple [rail env cont]
    \(ccons 'simple ^(bind '[rail env cont normalise-rail]
                          ^[rail env cont normalise-rail] global)
        '[first!]
        '(normalise-rail (rest rail) env
            (lambda [rest!]
               (cont (prep first! rest!)) )) )))
(define MAKE-REST-CONTINUATION
  (lambda simple [first! rail env cont]
    \(ccons 'simple ^(bind '[first! rail env cont normalise-rail]
                          ^[first! rail env cont normalise-rail] global)
        '[rest!]
        '(cont (prep first! rest!)) )))
(define MAKE-REPLY-CONTINUATION
  (lambda simple [level env]
    \(ccons 'simple ^(bind '[level env :read-normalise-print]
                    ^[level env :read-normalise-print] global)
        '[result]
        '(block (:prompt&reply level result)
                (:read-normalise-print level env) ) )))
(define MAKE-IF-CONTINUATION
  (lambda simple [premise c1 c2 env cont]
    \(ccons 'simple ^(bind '[premise c1 c2 env cont if]
                          ^[premise c1 c2 env cont if] global)
        '[premise!]
        '(normalise (ef \premise! c1 c2) env cont) )))
(define INITIAL-TOWER 
  (lambda simple [level] (scons level)) )
(define SHIFT-DOWN 
  (lambda simple [continuation state]
    (block (print '<shifting-down> primary-stream) (newline primary-stream)
    (prep continuation state) )) )
(define REIFY-CONTINUATION 
  (lambda simple [state]
    (if (= (length state) 1)
        (make-reply-continuation (1st state) global)
        (1st state) )))
(define SHIFT-UP 
  (lambda simple [state]
    (block (print '<shifting-up> primary-stream) (newline primary-stream)
    (if (= (length state) 1)
        (scons (1+ (1st state)))
(define PLAUSIBLE-ARGUMENTS-TO-A-CONTINUATION
  (lambda simple [args!]
    (and (rail args!) (= (length args!) 1)
         (handle (1st args!)) )))
(define PLAUSIBLE-ARGUMENTS-TO-NORMALISE
  (lambda simple [args!]
    (block (print '<plausible> ps) (newline ps)
           (print args! ps) (newline ps)
    (and (rail args!) (= (length args!) 3)
         (handle (1st args!))
         (plausible-environment-designator (2nd args!))
         (plausible-continuation-designator (3rd args!)) ))) )
(define PLAUSIBLE-ENVIRONMENT-DESIGNATOR
  (lambda simple [env!]
     (and (rail env!)
          (or (= env! ^global)
              (empty env!)
              (and (plausible-binding-designator (1st env!))
                   (plausible-environment-designator (rest env!)) )))))
(define PLAUSIBLE-BINDING-DESIGNATOR
  (lambda simple [b!]
    (and (rail b!) (= (length b!) 2)
         (handle (1st b!)) (atom \(1st b!))
         (handle (2nd b!)) )))
(define PLAUSIBLE-CONTINUATION-DESIGNATOR
  (lambda simple [c!]
    (and (closure c!) (not (reflective c!))
         (or (atom (pattern c!))
             (rail (pattern c!)) (= (length (pattern c!)) 1) ))))
(define EXTRACT 
  (lambda simple [variable function]
    \(binding variable (environment ^function)) ))
(define KERNEL-PRIMARY-CLOSURE 
  (lambda simple [closure]
    (not (= 'unknown (kernel-primary-type closure))) ))
(define KERNEL-PRIMARY-TYPE
  (lambda simple [closure]
    (identify-closure closure *kernel-primary-table*) ))
(set *KERNEL-PRIMARY-TABLE*
   [['normalise ^normalise]
    ['reduce ^reduce]
    ['normalise-rail ^normalise-rail]
    ['read-normalise-print ^:read-normalise-print]
    ['lambda (de-reflect ^lambda)]
    ['if (de-reflect ^if)] ])
(define KERNEL-CONTINUATION-CLOSURE 
  (lambda simple [closure]
    (not (= 'unknown (kernel-continuation-type closure))) ))
(define KERNEL-CONTINUATION-TYPE
  (lambda simple [closure]
    (identify-closure closure *kernel-continuation-table*) ))
(set *KERNEL-CONTINUATION-TABLE*
   [['proc  ^(make-proc-continuation  '? '? '? '?)]
    ['args  ^(make-args-continuation  '? '? '? '? '?)]
    ['first ^(make-first-continuation '? '? '?)]
    ['rest  ^(make-rest-continuation  '? '? '? '?)]
    ['reply ^(make-reply-continuation '? '?)]
    ['if    ^(make-if-continuation    '? '? '? '? '?)] ])
(define KERNEL-UTILITY
  (lambda simple [closure]
    (member closure *kernel-utility-table*) ))
(set *KERNEL-UTILITY-TABLE*
  [^binding ^bind ^rebind ^de-reflect ^primitive ^reflective
   ^normal  ^length
   ^append ^append*
   ^1st ^2nd ^3rd ^4th ^5th ^6th ^unit ^double ^member
   ^:prompt&read ^:prompt&reply ^environment] )
(define IDENTIFY-CLOSURE
  (lambda simple [closure table]
    (cond [(empty table) 'unknown]
          [(similar-closure closure (2nd (1st table)))
           (1st (1st table))]
          [$T (identify-closure closure (rest table))] )))
(define SIMILAR-CLOSURE
  (lambda simple [closure template]
    (or (= closure template)
        (and (isomorphic (pattern closure) (pattern template))
             (isomorphic (body closure) (body template))
             (= (reflective closure) (reflective template))
             (similar-environment (environment closure)
                                  (environment template) ))))) 
(define SIMILAR-ENVIRONMENT
  (lambda simple [environment template]
    (or (= ^environment ^template)
        (and (empty environment) (empty template))
        (and (not (empty template))
             (not (empty environment))
             (= (1st (1st environment)) (1st (1st template)))
             (or (= ' '? (2nd (1st template)))
                 (= (2nd (1st environment)) (2nd (1st template))))
             (similar-environment (rest environment)
                                  (rest template) )))))





(define :read-normalise-print
   (lambda simple [level env]
      (normalise (:prompt&read level) env
         (lambda simple [result]
            (block (:prompt&reply result level)
                   (:read-normalise-print level env) ))))) 

(define :prompt&read
  (lambda simple [level]
    (prompt&read level primary-stream) ))
(define :prompt&reply
  (lambda simple [result level]
     (prompt&reply result level primary-stream) ))