  $ I d : chap5c.scm , v 4.0 1995/07/10 06:51:25   

;;;(((((((((((((((((((((((((((((((( L i S P ))))))))))))))))))))))))))))))))
;;; This file is derived from the files that accompany the book:
      LISP Implantation Semantique Programmation ( InterEditions , France )
      or   Lisp In Small Pieces ( Cambridge University Press ) .
  By Christian Queinnec <  >
;;; The original sources can be downloaded from the author's website at
;;;   -systeme.lip6.fr/Christian.Queinnec/WWW/LiSP.html
;;; This file may have been altered from the original in order to work with
;;; modern schemes. The latest copy of these altered sources can be found at
;;;   -In-Small-Pieces
;;; If you want to report a bug in this program, open a GitHub Issue at the
;;; repo mentioned above.
;;; Check the README file before using this file.
;;;(((((((((((((((((((((((((((((((( L i S P ))))))))))))))))))))))))))))))))
;;; Scheme denotation with dynamic binding forms

;   Meaning  : Form -> Env * DynEnv * Cont * Store -> Val
; r   Env    : Var -> Loc
; d   DynEnv : Var -> Val
; s   Store  : Loc -> Val
; k   Cont   : Val * Store -> Val
; v   Val    : Fun | Int | Pair
  f    Fun     : (  ... ) * DynEnv * Cont * Store - > Val
      Cons    :   
; e   Form

;;; Injections  and projections
(define-class Value Object (content))

(define (inValue f)
  (make-Value f) )

(define (Value->Function e)
  (let ((c (Value-content e)))
    (if (procedure? c) c
        (wrong "Not a function" c) ) ) )

(define (Value->Pair e)
  (let ((c (Value-content e)))
    (if (cons? c) c
        (wrong "Not a pair" c) ) ) )

(define (Value->Integer e)
  (let ((c (Value-content e)))
    (if (integer? c) c
        (wrong "Not a pair" c) ) ) )

  Syntactical analysis

(define (meaning e)
  (if (atom? e)
      (if (symbol? e) (meaning-reference e)
                      (meaning-quotation e) )
      (case (car e)
        ((quote)  (meaning-quotation (cadr e)))
        ((lambda) (meaning-abstraction (cadr e) (cddr e)))
        ((if)     (meaning-alternative (cadr e) (caddr e) (cadddr e)))
        ((begin)  (meaning-sequence (cdr e)))
        ((set!)   (meaning-assignment (cadr e) (caddr e)))
        ((dynamic-let)
         (meaning-dynamic-binding (car (cadr e)) (cadr (cadr e)) (cddr e)) )
        ((dynamic)
         (meaning-dynamic-reference (cadr e)) )
        (else     (meaning-application (car e) (cdr e))) ) ) )

(define (meaning-dynamic-reference n)
  (lambda (r d k s)
    (k (d n) s) ) )

(define (meaning-dynamic-binding n e e+)
  (lambda (r d k s)
    ((meaning e) r d
                 (lambda (v s1)
                   ((meaning*-sequence e+)
                    r (extend d n v) k s1 ) )
                 s ) ) )

(define (meaning-quotation v)
  (lambda (r d k s)
    (translate v s k) ) )

(define (meaning-reference n)
  (lambda (r d k s)
    (k (s (r n)) s) ) )

(define (ef v v1 v2)
  (v v1 v2) )

(define (boolify v)
  (if (equal? v (inValue #f))
      (lambda (x y) y) 
      (lambda (x y) x) ) )

(define (meaning-alternative e1 e2 e3)
  (lambda (r d k s)
    ((meaning e1) r d 
                  (lambda (v s1)
                    ((ef (boolify v) (meaning e2) (meaning e3))
                     r d k s1 ) )
                  s ) ) )

(define (meaning-assignment n e)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   (k v (extend s1 (r n) v)) )
                 s ) ) )

;;; This denotation does not allow dotted variables.

(define (meaning-abstraction n* e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (= (length v*) (length n*))
                    (allocate s1 (length n*)
                              (lambda (s2 a*)
                                ((meaning*-sequence e+) 
                                 (extend* r n* a*)
                                 d1
                                 k1
                                 (extend* s2 a* v*) ) ) )
                    (wrong "Incorrect arity") ) ))
       s ) ) )

;;; Nor does this one. Meaning-fix-abstraction is the same as the
;;; previous one except that it is written in a form that makes it
;;; similar to meaning-dotted-abstraction.

(define (meaning-fix-abstraction n* e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (= (length v*) (length n*))
                    (((meaning-regular-variables n*)
                      (lambda (v* r d k s) ((meaning*-sequence e+) r d k s)) )
                     v* r d1 k1 s1 )
                    (wrong "Incorrect arity") ) ))
       s ) ) )

(define (meaning-regular-variables n*)
  (lambda (m)
    (if (pair? n*)
      ((meaning-variable (car n*))
       ((meaning-regular-variables (cdr n*)) m) )
      m ) ) )

(define (meaning-variable n)
  (lambda (m)
    (lambda (v* r d k s)
      (allocate 
        s 1 (lambda (s a*)
              (let ((a (car a*)))
                (m (cdr v*) (extend r n a) d k (extend s a (car v*))) ) ) ) ) ) )

(define (meaning-possibly-dotted-abstraction n* e+)
  (let parse ((n* n*)
              (regular '()) )
    (cond 
     ((pair? n*) (parse (cdr n*) (cons (car n*) regular)))
     ((null? n*) (meaning-fix-abstraction (reverse regular) e+))
     (else       (meaning-dotted-abstraction (reverse regular) n* e+)) ) ) )

(define (meaning-dotted-abstraction n* n e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (>= (length v*) (length n*))
                    (((meaning-regular-variables n*)
                      ((meaning-dotted-variable n) 
                       (lambda (v* r d k s) 
                         ((meaning*-sequence e+) r d k s) ) ) )
                     v* r d1 k1 s1 )
                    (wrong "Incorrect arity") ) ))
       s ) ) )

(define (meaning-dotted-variable n)
  (lambda (m)
    (lambda (v* r d k s)
      (letrec ((listify 
                 (lambda (v* s q)
                   (if (pair? v*)
                     (allocate 
                       s 2 (lambda (s a*)
                             (listify (cdr v*)
                                      (extend s (car a*) (car v*))
                                      (lambda (v s)
                                        (q (inValue a*)
                                           (extend s (cadr a*) v) ) ) ) ))
                     (q (inValue '()) s) ) )))
        (listify v* s (lambda (v s)
                        (allocate s 1
                                  (lambda (s a*)
                                    (let ((a (car a*)))
                                      (m '() 
                                         (extend r n a)
                                         d 
                                         k 
                                         (extend s a v) ) ) ) ) )) ) ) ) )

  Retrofit !

(set! meaning-abstraction meaning-possibly-dotted-abstraction)

(define (meaning-application e e*)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (f s1)
                   ((meaning* e*) r d 
                                  (lambda (v* s2)
                                    ((Value->Function f) v* d k s2) )
                                  s1 ) )
                 s ) ) )

;;; iterator aka eprogn

(define (meaning-sequence e+)
  (meaning*-sequence e+) )

(define (meaning*-sequence e+)
  (if (pair? e+)
      (if (pair? (cdr e+))
          (meaning*-multiple-sequence (car e+) (cdr e+))
          (meaning*-single-sequence (car e+)) )
      (wrong "Illegal syntax") ) )

;;; The meaning-single-sequence function can be eta-simplified as well as
;;; the meaning-sequence function above.

(define (meaning*-single-sequence e)
  (lambda (r d k s)
    ((meaning e) r d k s) ) )

(define (meaning*-multiple-sequence e e+)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   ((meaning*-sequence e+) r d k s1) )
                 s ) ) )

;;; Iterator aka evlis

(define (meaning* e*)
  (if (pair? e*)
      (meaning-some-arguments (car e*) (cdr e*))
      (meaning-no-argument) ) )

(define (meaning-some-arguments e e*)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   ((meaning* e*) r d 
                                  (lambda (v* s2)
                                    (k (cons v v*) s2) )
                                  s1 ) )
                 s ) ) )

(define (meaning-no-argument)
  (lambda (r d k s)
    (k (list) s) ) )

;;; Representation of environment and store

(define (s.init a)
  (wrong "No such address" a) )

(define (r.init n)
  (wrong "No such variable" n) )

(define (d.init n)
  (wrong "No such dynamic variable" n) )

(define (extend fn pt im)
  (lambda (x) (if (equal? pt x) im (fn x))) )

(define (extend* fn pts ims)
  (if (pair? pts)
      (extend (extend* fn (cdr pts) (cdr ims))
              (car pts) (car ims) )
      fn ) )

;;; Locations are represented by growing positive integers.
;;; No attempt is done to garbage collect locations.
;;; Moreover allocate is not a real function since it allocates new
;;; unseen locations each time it is invoked.

(define allocate 
  (let ((loc 0))
    (lambda (s n q)
      (let loop ((n n)
                 (a* '()) )
        (if (<= n 0) (q s a*)
                     (begin (set! loc (- loc 1))
                            (loop (- n 1)
                                  (cons loc a*) ) ) ) ) ) ) )

  Two macros to define the original environment and store .

(define-syntax definitial 
  (syntax-rules ()
    ((definitial name value)
     (allocate s.init 1
               (lambda (s a*)
                 (set! r.init (extend r.init 'name (car a*)))
                 (set! s.init (extend s (car a*) value))
                 'name ) ) ) ) )

(define-syntax defprimitive
  (syntax-rules ()
    ((defprimitive name value arity)
     (definitial name 
       (inValue 
        (lambda (v* d k s) 
          (if (= arity (length v*))
              (k (apply value v*) s)
              (wrong "Incorrect arity" 'name) ) ) ) ) ) ) )

(define-syntax defarithmetic
  (syntax-rules ()
    ((defprimitive name value arity)
     (definitial name 
       (inValue 
        (lambda (v* d k s) 
          (if (= arity (length v*))
              (k (inValue (apply value (map Value->Integer v*))) s)
              (wrong "Incorrect arity" 'name) ) ) ) ) ) ) )

(definitial cons 
  (inValue 
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (allocate s 2
                   (lambda (s a*) (k (inValue a*) (extend* s a* v*))) )
         (wrong "incorrect arity" 'cons) ) ) ) )

(definitial car 
  (inValue 
   (lambda (v* d k s)
     (if (= 1 (length v*))
         (k (s (car (Value->Pair (car v*)))) s)
         (wrong "incorrect arity" 'car) ) ) ) )

(definitial cdr 
  (inValue 
   (lambda (v* d k s)
     (if (= 1 (length v*))
         (k (s (cadr (Value->Pair (car v*)))) s)
         (wrong "incorrect arity" 'cdr) ) ) ) )

(defprimitive pair? 
  (lambda (v) (inValue (cons? (Value-content v))))
  1 )

;;; Hack
(defprimitive eq? 
  (lambda (v1 v2) (inValue (eq? (Value-content v1)
                                (Value-content v2) )))
  2 )

(defprimitive symbol? 
  (lambda (v) (inValue (symbol? (Value-content v))))
  1 )

(definitial set-car! 
  (inValue
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (k (car v*)
            (extend s (car (Value->Pair (car v*)))
                    (cadr v*) ) ) 
         (wrong "incorrect arity" 'set-car!) ) ) ) )

(definitial set-cdr! 
  (inValue
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (k (car v*)
            (extend s (cadr (Value->Pair (car v*)))
                    (cadr v*) ) ) 
         (wrong "incorrect arity" 'set-cdr!) ) ) ) )

(defarithmetic + + 2)
(defarithmetic - - 2)
(defarithmetic < < 2)
(defarithmetic > > 2)
(defarithmetic = = 2)
(defarithmetic * * 2)
(defarithmetic <= <= 2)
(defarithmetic >= >= 2)
(defarithmetic remainder remainder 2)

(definitial call/cc
  (inValue
   (lambda (v1* d1 k1 s1) 
     (if (= 1 (length v1*))
         ((Value->Function (car v1*))
          (list (inValue 
                 (lambda (v2* d2 k2 s2)
                   (if (= 1 (length v2*))
                       (k1 (car v2*) s2)
                       (wrong "Incorrect arity" 'k) ) ) ))
          d1
          k1
          s1 )
         (wrong "Incorrect arity" 'call/cc) ) ) ) )

(definitial apply
  (inValue
   (lambda (v* d k s)
     (if (>= (length v*) 2)
         ((Value->Function (car v*))
          (let collect ((v* (cdr v*)))
            (if (null? (cdr v*))
                (let flat ((v (car v*)))
                  (if (cons? (Value-content v))
                      (cons (s (car (Value->Pair v)))
                            (flat (s (cadr (Value->Pair v)))) )
                      '() ) )
                (cons (car v*) (collect (cdr v*))) ) )
          d k s )
         (wrong "Incorrect arity" 'apply) ) ) ) )

(definitial list
  (inValue 
   (lambda (v* d k s)
     (let alloc ((v* v*)
                 (s s)
                 (k k) )
       (if (pair? v*)
           (allocate s 2
                     (lambda (s a*)
                       (alloc (cdr v*)
                              (extend s (car a*) (car v*))
                              (lambda (v s)
                                (k (inValue a*) (extend s (cadr a*) v)) ) ) ) )
           (k (inValue '()) s) ) ) ) ) )

(definitial t (inValue #t))
(definitial f (inValue #f))
(definitial nil (inValue '()))

;;; Some free global locations since they cannot be dynamically defined.

(definitial x 'void)
(definitial y 'void)
(definitial z 'void)
(definitial a 'void)
(definitial b 'void)
(definitial c 'void)
(definitial foo 'void)
(definitial bar 'void)
(definitial hux 'void)
(definitial fib 'void)
(definitial fact 'void)
(definitial visit 'void)
(definitial length 'void)
(definitial primes 'void)

  A cons - cell is represented by a sequence of two locations ( ie a
  list of two integers )

(define (cons? e)
  (and (pair? e)
       (integer? (car e))
       (< (car e) 0)
       (pair? (cdr e))
       (integer? (cadr e))
       (< (cadr e) 0)
       (null? (cddr e)) ) )

(define (convert e s)
  (define (conv e)
    (if (cons? e)
        (cons (conv (Value-content (s (car e))))
              (conv (Value-content (s (cadr e)))) )
        e ) ) 
  (conv (Value-content e)) )

(define (translate e s q)
  (if (pair? e) 
      (translate 
       (car e)
       s
       (lambda (v1 s1)
         (translate 
          (cdr e)
          s1
          (lambda (v2 s2)
            (allocate 
             s2 2 (lambda (s a*)
                    (q (inValue a*)
                       (extend (extend s (car a*) v1)
                               (cadr a*) v2 )) ) ) ) ) ) )
      (q (inValue e) s) ) )

  Run the interpreter with :               ( denScheme )

(define (denScheme)
  (interpreter 
   "denScheme? "
   "denScheme= "
   #t
   (lambda (read print error)
     (set! wrong error)
     (let ((s.current s.init))
       (lambda ()
         ((meaning (read))
          r.init
          d.init
          (lambda (v s.final)
            (set! s.current s.final)
            (print (convert v s.final)) )
          s.current ) ) ) ) ) )

(define (test-denScheme file)
  (suite-test 
   file
   "denScheme? " 
   "denScheme= " 
   #t
   (lambda (read check error)
     (set! wrong error)
     (let ((s.current s.init))
       (lambda ()
         ((meaning (read))
          r.init
          d.init
          (lambda (v s.final)
            (set! s.current s.final)
            (check (convert v s.final)) )
          s.current ) ) ) )
   equal? ) )

;;; end of chap5c.scm

(((((((((((((((((((((((((((((((( L i S P ))))))))))))))))))))))))))))))))
 This file is derived from the files that accompany the book:
 The original sources can be downloaded from the author's website at
   -systeme.lip6.fr/Christian.Queinnec/WWW/LiSP.html
 This file may have been altered from the original in order to work with
 modern schemes. The latest copy of these altered sources can be found at
   -In-Small-Pieces
 If you want to report a bug in this program, open a GitHub Issue at the
 repo mentioned above.
 Check the README file before using this file.
(((((((((((((((((((((((((((((((( L i S P ))))))))))))))))))))))))))))))))
 Scheme denotation with dynamic binding forms
   Meaning  : Form -> Env * DynEnv * Cont * Store -> Val
 r   Env    : Var -> Loc
 d   DynEnv : Var -> Val
 s   Store  : Loc -> Val
 k   Cont   : Val * Store -> Val
 v   Val    : Fun | Int | Pair
 e   Form
 Injections  and projections
 This denotation does not allow dotted variables.
 Nor does this one. Meaning-fix-abstraction is the same as the
 previous one except that it is written in a form that makes it
 similar to meaning-dotted-abstraction.
 iterator aka eprogn
 The meaning-single-sequence function can be eta-simplified as well as
 the meaning-sequence function above.
 Iterator aka evlis
 Representation of environment and store
 Locations are represented by growing positive integers.
 No attempt is done to garbage collect locations.
 Moreover allocate is not a real function since it allocates new
 unseen locations each time it is invoked.
 Hack
 Some free global locations since they cannot be dynamically defined.
 end of chap5c.scm
  $ I d : chap5c.scm , v 4.0 1995/07/10 06:51:25   

      LISP Implantation Semantique Programmation ( InterEditions , France )
      or   Lisp In Small Pieces ( Cambridge University Press ) .
  By Christian Queinnec <  >

  f    Fun     : (  ... ) * DynEnv * Cont * Store - > Val
      Cons    :   

(define-class Value Object (content))

(define (inValue f)
  (make-Value f) )

(define (Value->Function e)
  (let ((c (Value-content e)))
    (if (procedure? c) c
        (wrong "Not a function" c) ) ) )

(define (Value->Pair e)
  (let ((c (Value-content e)))
    (if (cons? c) c
        (wrong "Not a pair" c) ) ) )

(define (Value->Integer e)
  (let ((c (Value-content e)))
    (if (integer? c) c
        (wrong "Not a pair" c) ) ) )

  Syntactical analysis

(define (meaning e)
  (if (atom? e)
      (if (symbol? e) (meaning-reference e)
                      (meaning-quotation e) )
      (case (car e)
        ((quote)  (meaning-quotation (cadr e)))
        ((lambda) (meaning-abstraction (cadr e) (cddr e)))
        ((if)     (meaning-alternative (cadr e) (caddr e) (cadddr e)))
        ((begin)  (meaning-sequence (cdr e)))
        ((set!)   (meaning-assignment (cadr e) (caddr e)))
        ((dynamic-let)
         (meaning-dynamic-binding (car (cadr e)) (cadr (cadr e)) (cddr e)) )
        ((dynamic)
         (meaning-dynamic-reference (cadr e)) )
        (else     (meaning-application (car e) (cdr e))) ) ) )

(define (meaning-dynamic-reference n)
  (lambda (r d k s)
    (k (d n) s) ) )

(define (meaning-dynamic-binding n e e+)
  (lambda (r d k s)
    ((meaning e) r d
                 (lambda (v s1)
                   ((meaning*-sequence e+)
                    r (extend d n v) k s1 ) )
                 s ) ) )

(define (meaning-quotation v)
  (lambda (r d k s)
    (translate v s k) ) )

(define (meaning-reference n)
  (lambda (r d k s)
    (k (s (r n)) s) ) )

(define (ef v v1 v2)
  (v v1 v2) )

(define (boolify v)
  (if (equal? v (inValue #f))
      (lambda (x y) y) 
      (lambda (x y) x) ) )

(define (meaning-alternative e1 e2 e3)
  (lambda (r d k s)
    ((meaning e1) r d 
                  (lambda (v s1)
                    ((ef (boolify v) (meaning e2) (meaning e3))
                     r d k s1 ) )
                  s ) ) )

(define (meaning-assignment n e)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   (k v (extend s1 (r n) v)) )
                 s ) ) )


(define (meaning-abstraction n* e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (= (length v*) (length n*))
                    (allocate s1 (length n*)
                              (lambda (s2 a*)
                                ((meaning*-sequence e+) 
                                 (extend* r n* a*)
                                 d1
                                 k1
                                 (extend* s2 a* v*) ) ) )
                    (wrong "Incorrect arity") ) ))
       s ) ) )


(define (meaning-fix-abstraction n* e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (= (length v*) (length n*))
                    (((meaning-regular-variables n*)
                      (lambda (v* r d k s) ((meaning*-sequence e+) r d k s)) )
                     v* r d1 k1 s1 )
                    (wrong "Incorrect arity") ) ))
       s ) ) )

(define (meaning-regular-variables n*)
  (lambda (m)
    (if (pair? n*)
      ((meaning-variable (car n*))
       ((meaning-regular-variables (cdr n*)) m) )
      m ) ) )

(define (meaning-variable n)
  (lambda (m)
    (lambda (v* r d k s)
      (allocate 
        s 1 (lambda (s a*)
              (let ((a (car a*)))
                (m (cdr v*) (extend r n a) d k (extend s a (car v*))) ) ) ) ) ) )

(define (meaning-possibly-dotted-abstraction n* e+)
  (let parse ((n* n*)
              (regular '()) )
    (cond 
     ((pair? n*) (parse (cdr n*) (cons (car n*) regular)))
     ((null? n*) (meaning-fix-abstraction (reverse regular) e+))
     (else       (meaning-dotted-abstraction (reverse regular) n* e+)) ) ) )

(define (meaning-dotted-abstraction n* n e+)
  (lambda (r d k s)
    (k (inValue (lambda (v* d1 k1 s1)
                  (if (>= (length v*) (length n*))
                    (((meaning-regular-variables n*)
                      ((meaning-dotted-variable n) 
                       (lambda (v* r d k s) 
                         ((meaning*-sequence e+) r d k s) ) ) )
                     v* r d1 k1 s1 )
                    (wrong "Incorrect arity") ) ))
       s ) ) )

(define (meaning-dotted-variable n)
  (lambda (m)
    (lambda (v* r d k s)
      (letrec ((listify 
                 (lambda (v* s q)
                   (if (pair? v*)
                     (allocate 
                       s 2 (lambda (s a*)
                             (listify (cdr v*)
                                      (extend s (car a*) (car v*))
                                      (lambda (v s)
                                        (q (inValue a*)
                                           (extend s (cadr a*) v) ) ) ) ))
                     (q (inValue '()) s) ) )))
        (listify v* s (lambda (v s)
                        (allocate s 1
                                  (lambda (s a*)
                                    (let ((a (car a*)))
                                      (m '() 
                                         (extend r n a)
                                         d 
                                         k 
                                         (extend s a v) ) ) ) ) )) ) ) ) )

  Retrofit !

(set! meaning-abstraction meaning-possibly-dotted-abstraction)

(define (meaning-application e e*)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (f s1)
                   ((meaning* e*) r d 
                                  (lambda (v* s2)
                                    ((Value->Function f) v* d k s2) )
                                  s1 ) )
                 s ) ) )


(define (meaning-sequence e+)
  (meaning*-sequence e+) )

(define (meaning*-sequence e+)
  (if (pair? e+)
      (if (pair? (cdr e+))
          (meaning*-multiple-sequence (car e+) (cdr e+))
          (meaning*-single-sequence (car e+)) )
      (wrong "Illegal syntax") ) )


(define (meaning*-single-sequence e)
  (lambda (r d k s)
    ((meaning e) r d k s) ) )

(define (meaning*-multiple-sequence e e+)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   ((meaning*-sequence e+) r d k s1) )
                 s ) ) )


(define (meaning* e*)
  (if (pair? e*)
      (meaning-some-arguments (car e*) (cdr e*))
      (meaning-no-argument) ) )

(define (meaning-some-arguments e e*)
  (lambda (r d k s)
    ((meaning e) r d 
                 (lambda (v s1)
                   ((meaning* e*) r d 
                                  (lambda (v* s2)
                                    (k (cons v v*) s2) )
                                  s1 ) )
                 s ) ) )

(define (meaning-no-argument)
  (lambda (r d k s)
    (k (list) s) ) )


(define (s.init a)
  (wrong "No such address" a) )

(define (r.init n)
  (wrong "No such variable" n) )

(define (d.init n)
  (wrong "No such dynamic variable" n) )

(define (extend fn pt im)
  (lambda (x) (if (equal? pt x) im (fn x))) )

(define (extend* fn pts ims)
  (if (pair? pts)
      (extend (extend* fn (cdr pts) (cdr ims))
              (car pts) (car ims) )
      fn ) )


(define allocate 
  (let ((loc 0))
    (lambda (s n q)
      (let loop ((n n)
                 (a* '()) )
        (if (<= n 0) (q s a*)
                     (begin (set! loc (- loc 1))
                            (loop (- n 1)
                                  (cons loc a*) ) ) ) ) ) ) )

  Two macros to define the original environment and store .

(define-syntax definitial 
  (syntax-rules ()
    ((definitial name value)
     (allocate s.init 1
               (lambda (s a*)
                 (set! r.init (extend r.init 'name (car a*)))
                 (set! s.init (extend s (car a*) value))
                 'name ) ) ) ) )

(define-syntax defprimitive
  (syntax-rules ()
    ((defprimitive name value arity)
     (definitial name 
       (inValue 
        (lambda (v* d k s) 
          (if (= arity (length v*))
              (k (apply value v*) s)
              (wrong "Incorrect arity" 'name) ) ) ) ) ) ) )

(define-syntax defarithmetic
  (syntax-rules ()
    ((defprimitive name value arity)
     (definitial name 
       (inValue 
        (lambda (v* d k s) 
          (if (= arity (length v*))
              (k (inValue (apply value (map Value->Integer v*))) s)
              (wrong "Incorrect arity" 'name) ) ) ) ) ) ) )

(definitial cons 
  (inValue 
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (allocate s 2
                   (lambda (s a*) (k (inValue a*) (extend* s a* v*))) )
         (wrong "incorrect arity" 'cons) ) ) ) )

(definitial car 
  (inValue 
   (lambda (v* d k s)
     (if (= 1 (length v*))
         (k (s (car (Value->Pair (car v*)))) s)
         (wrong "incorrect arity" 'car) ) ) ) )

(definitial cdr 
  (inValue 
   (lambda (v* d k s)
     (if (= 1 (length v*))
         (k (s (cadr (Value->Pair (car v*)))) s)
         (wrong "incorrect arity" 'cdr) ) ) ) )

(defprimitive pair? 
  (lambda (v) (inValue (cons? (Value-content v))))
  1 )

(defprimitive eq? 
  (lambda (v1 v2) (inValue (eq? (Value-content v1)
                                (Value-content v2) )))
  2 )

(defprimitive symbol? 
  (lambda (v) (inValue (symbol? (Value-content v))))
  1 )

(definitial set-car! 
  (inValue
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (k (car v*)
            (extend s (car (Value->Pair (car v*)))
                    (cadr v*) ) ) 
         (wrong "incorrect arity" 'set-car!) ) ) ) )

(definitial set-cdr! 
  (inValue
   (lambda (v* d k s)
     (if (= 2 (length v*))
         (k (car v*)
            (extend s (cadr (Value->Pair (car v*)))
                    (cadr v*) ) ) 
         (wrong "incorrect arity" 'set-cdr!) ) ) ) )

(defarithmetic + + 2)
(defarithmetic - - 2)
(defarithmetic < < 2)
(defarithmetic > > 2)
(defarithmetic = = 2)
(defarithmetic * * 2)
(defarithmetic <= <= 2)
(defarithmetic >= >= 2)
(defarithmetic remainder remainder 2)

(definitial call/cc
  (inValue
   (lambda (v1* d1 k1 s1) 
     (if (= 1 (length v1*))
         ((Value->Function (car v1*))
          (list (inValue 
                 (lambda (v2* d2 k2 s2)
                   (if (= 1 (length v2*))
                       (k1 (car v2*) s2)
                       (wrong "Incorrect arity" 'k) ) ) ))
          d1
          k1
          s1 )
         (wrong "Incorrect arity" 'call/cc) ) ) ) )

(definitial apply
  (inValue
   (lambda (v* d k s)
     (if (>= (length v*) 2)
         ((Value->Function (car v*))
          (let collect ((v* (cdr v*)))
            (if (null? (cdr v*))
                (let flat ((v (car v*)))
                  (if (cons? (Value-content v))
                      (cons (s (car (Value->Pair v)))
                            (flat (s (cadr (Value->Pair v)))) )
                      '() ) )
                (cons (car v*) (collect (cdr v*))) ) )
          d k s )
         (wrong "Incorrect arity" 'apply) ) ) ) )

(definitial list
  (inValue 
   (lambda (v* d k s)
     (let alloc ((v* v*)
                 (s s)
                 (k k) )
       (if (pair? v*)
           (allocate s 2
                     (lambda (s a*)
                       (alloc (cdr v*)
                              (extend s (car a*) (car v*))
                              (lambda (v s)
                                (k (inValue a*) (extend s (cadr a*) v)) ) ) ) )
           (k (inValue '()) s) ) ) ) ) )

(definitial t (inValue #t))
(definitial f (inValue #f))
(definitial nil (inValue '()))


(definitial x 'void)
(definitial y 'void)
(definitial z 'void)
(definitial a 'void)
(definitial b 'void)
(definitial c 'void)
(definitial foo 'void)
(definitial bar 'void)
(definitial hux 'void)
(definitial fib 'void)
(definitial fact 'void)
(definitial visit 'void)
(definitial length 'void)
(definitial primes 'void)

  A cons - cell is represented by a sequence of two locations ( ie a
  list of two integers )

(define (cons? e)
  (and (pair? e)
       (integer? (car e))
       (< (car e) 0)
       (pair? (cdr e))
       (integer? (cadr e))
       (< (cadr e) 0)
       (null? (cddr e)) ) )

(define (convert e s)
  (define (conv e)
    (if (cons? e)
        (cons (conv (Value-content (s (car e))))
              (conv (Value-content (s (cadr e)))) )
        e ) ) 
  (conv (Value-content e)) )

(define (translate e s q)
  (if (pair? e) 
      (translate 
       (car e)
       s
       (lambda (v1 s1)
         (translate 
          (cdr e)
          s1
          (lambda (v2 s2)
            (allocate 
             s2 2 (lambda (s a*)
                    (q (inValue a*)
                       (extend (extend s (car a*) v1)
                               (cadr a*) v2 )) ) ) ) ) ) )
      (q (inValue e) s) ) )

  Run the interpreter with :               ( denScheme )

(define (denScheme)
  (interpreter 
   "denScheme? "
   "denScheme= "
   #t
   (lambda (read print error)
     (set! wrong error)
     (let ((s.current s.init))
       (lambda ()
         ((meaning (read))
          r.init
          d.init
          (lambda (v s.final)
            (set! s.current s.final)
            (print (convert v s.final)) )
          s.current ) ) ) ) ) )

(define (test-denScheme file)
  (suite-test 
   file
   "denScheme? " 
   "denScheme= " 
   #t
   (lambda (read check error)
     (set! wrong error)
     (let ((s.current s.init))
       (lambda ()
         ((meaning (read))
          r.init
          d.init
          (lambda (v s.final)
            (set! s.current s.final)
            (check (convert v s.final)) )
          s.current ) ) ) )
   equal? ) )

