unofficial mirror of guile-user@gnu.org 
 help / color / mirror / Atom feed
From: Utkarsh Singh <utkarsh190601@gmail.com>
To: guile-user@gnu.org
Subject: [Utkarsh Singh] Undefined simultaneous definitions
Date: Mon, 20 Sep 2021 09:46:43 +0530	[thread overview]
Message-ID: <877dfbankk.fsf@gmail.com> (raw)
In-Reply-To: 87a6k89btn.fsf@gmail.com

[-- Attachment #1: Type: text/plain, Size: 292 bytes --]


Note: Resending because previous message doesn't appears in archive.

-------------------- Start of forwarded message --------------------
From: Utkarsh Singh <utkarsh190601@gmail.com>
To: guile-user@gnu.org
Subject: Undefined simultaneous definitions
Date: Mon, 20 Sep 2021 08:45:48 +0530


[-- Attachment #2.1: Type: text/plain, Size: 1431 bytes --]

Hi Guilers,

First of all I would like to thank you for maintaining this wonderful
programming language.

SICP Section 4.3 defines a non-deterministic (or ambiguous) evaluator
which helps in non-deterministic computing.  In implementing such an
evaluator I am having difficulty in defining `letrec' special form and
procedure definition with simultaneous internal definition.  For
example, consider the following REPL session:

;;; Amb-Eval input:
(define (findout32 x)
  (letrec ((even?
	    (lambda (n)
	      (if (= n 0)
		  #t
		(odd? (- n 1)))))
	   (odd?
	    (lambda (n)
	      (if (= n 0)
		  #f
		(even? (- n 1))))))
    (cond
     ((even? x) 20)
     ((odd? x) 30)
     (else 40))))

;;; Starting a new problem 
;;; Amb-Eval value:
ok

;;; Amb-Eval input:
(findout32 10)

;;; Starting a new problem ERROR: In procedure scm-error:
Unassigned variable -- LOOKUP-VARIABLE-VALUE odd?

I tried to debug this issue using `trace' command and it seems that my
evaluator is *not* correctly evaluating sequence of `set!' expression
generated by `scan-out-defines' (see source file for definition).

For now I am going to attach the following files in order to
sufficiently explain the problem:

1. ambeval.scm (Implementation of evaluator)
2. test-ambeval.scm (Test suite for evaluator)
3. test-letrec.log (Erroneous log generated by test suite for `letrec')

Thank you,
Utkarsh Singh

-- 
Utkarsh Singh
https://utkarshsingh.xyz/


[-- Attachment #2.2: Evaluator --]
[-- Type: text/plain, Size: 25508 bytes --]

;; Non-deterministic meta-circular evaluator (in/for Scheme).

(define-module (sicp ch-4 ambeval)
  #:use-module (sicp ch-4 table)
  #:export (the-global-environment
	    execute-application
	    ambeval-eval
	    driver-loop))

;; NOTE 2021-09-20: This program creates of non-deterministic (or ambiguous)
;; evaluator by introducing a special form `amb' (syntax defined below) which
;; combined with `require' special form can be used to perform non-deterministic
;; computing.  For example, to ambiguously return an element of a list ITEMS, we
;; can use:
;;
;; (define (an-element-of items)
;; (require (not (null? items)))
;; (amb (car items) (an-element-of (cdr items))))

;; List of primitive procedures
(define primitive-procedures
  (list
   (list 'cons cons)
   (list 'list list)

   (list 'car car)
   (list 'cdr cdr)
   (list 'cadr cadr)
   (list 'cddr cddr)
   (list 'assoc assoc)
   (list 'memq memq)
   (list 'member member)

   (list 'not not)
   (list 'null? null?)
   (list 'eq? eq?)
   (list 'equal? equal?)
   (list '= =)

   (list '1+ 1+)
   (list '1- 1-)
   (list '+ +)
   (list '- -)
   (list '* *)
   (list '/ /)
   (list 'remainder remainder)
   (list '> >)
   (list '< <)))

(define input-prompt ";;; Amb-Eval input:")

(define output-prompt ";;; Amb-Eval value:")

;;; Constructors

(define (make-quoted exp)
  (list 'quote exp))

;; Make a lambda expression with formal paramater PARAMATER and body BODY.
(define (make-define parameters body)
  (cons 'define (cons parameters body)))

;; Make a lambda expression with formal paramater PARAMATER and body BODY.
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))

;; Make a if expression with predicate PREDICATE, consequent CONSEQUENT
;; and alternative ALTERNATIVE.
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; Make a begin expression with sequence of expression SEQ.
(define (make-begin seq) (cons 'begin seq))

(define (make-let var-list body)
  (list 'let var-list body))

(define (make-set! var body)
  (list 'set! var body))

;; Make a procedure expressin with formal parameter PARAMETER, body BODY in
;; environment ENV.
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))

(define (make-environment frame)
  (cons '*env* frame))

(define (make-frame variables values)
  (map cons variables values))

;;; Selectors

;; Syntax for quotation: (quote <text-of-quotation>)

;; Return text-of-quotation in quotation expression EXP.
(define (text-of-quotation exp) (cadr exp))

;; Syntax for assignment: (set! <var> <value>)

;; Return variable in assignment expression EXP.
(define (assignment-variable exp) (cadr exp))

;; Return value in assignment expression EXP.
(define (assignment-value exp) (caddr exp))

;; Syntax for definition: (define <var> <value>)

;; Return variable in definition expression EXP.
(define (definition-variable exp)
  (if (symbol? (cadr exp))
      (cadr exp)			; symbol name
      (caadr exp)))			; procedure name

;; Return value in definition expression EXP.
(define (definition-value exp)
  (if (symbol? (cadr exp))
      (caddr exp)
      (make-lambda (cdadr exp)		; formal parameter
                   (cddr exp))))	; body

;; Syntax for lambda: (lambda (<parameter_1> ... <parameter_n>) <body>)

;; Return parameter of lambda expression EXP.
(define (lambda-parameters exp) (cadr exp))

;; Return body of lambda expression EXP.
(define (lambda-body exp) (cddr exp))

;; Syntax for let: (let ((<var_1> <exp_1>) ... (<var_n> <exp_n>)) <body>)

;; Return list of form: (<variables> <expression>) in let expression EXP.
(define (let-varlist exp)
  (cond
   ((or (null? (car exp)) (null? (caar exp)))
    (error "Syntax error -- LET-VARLIST" exp))
   (else
    ;; REVIEW 2021-09-11: Is there a way to use single `map'?
    (list (map car (car exp))
	  (map cadr (car exp))))))

;; Return body of let expression EXP.
(define (let-body exp) (cdr exp))

;; Append VAR-VALUE pair into let expression EXP.
(define (let-append var value exp)
  (if (null? exp)
      (make-let (list (list var (make-quoted '*unassigned*)))
		(make-set! var value))
      (append
       (list 'let
	     (cons (list var (make-quoted '*unassigned*)) (cadr exp)))
       (list (make-set! var value))
       (cddr exp))))

;; Syntax for if: (if <predicate> <consequent> <alternative>)

;; Return predicate of if expression EXP.
(define (if-predicate exp) (cadr exp))

;; Return consequent of if expression EXP.
(define (if-consequent exp) (caddr exp))

;; Return alternative of if expression EXP.
(define (if-alternative exp)
  (if (not (null? (cdddr exp)))
      (cadddr exp)
      #f))

;; Syntax for begin: (begin <seq_1> <seq_2> ... <seq_n>)

;; TODO 2021-09-09: Document this after reading section 5.4
(define (begin-actions exp) (cdr exp))

;; Return first expression of begin sequence SEQ.
(define (first-exp seq) (car seq))

;; Return rest of the expressions of begin sequence SEQ.
(define (rest-exps seq) (cdr seq))

;; Syntax of a procedure application: (<operator> <operand_1> ... <operand_n>)

;; Return operator of procedure application expression EXP.
(define (operator exp) (car exp))

;; Return operands of procedure application expression EXP.
(define (operands exp) (cdr exp))

;; Return first operand in operand list OPS.
(define (first-operand ops) (car ops))

;; Return rest of the operand in operator list OPS.
(define (rest-operands ops) (cdr ops))

;; Syntax of a cond expression: (cond ((predicate_1 body_1) ... (predicate_n body_n)))

;; Return clauses of cond expression EXP.
(define (cond-clauses exp) (cdr exp))

;; Return predicate of cond clause CLAUSE.
(define (cond-predicate clause) (car clause))

;; Return predicate of extended cond clause CLAUSE.
(define (cond-extended-predicate clause) (car clause))

;; Return action sequence of cond clause CLAUSE.
(define (cond-actions clause) (cdr clause))

;; Return action sequence of extended clause CLAUSE.
(define (cond-extended-action clause) (caddr clause))

;; Return parameters of procedure expression P.
(define (procedure-parameters p) (cadr p))

;; Return body of procedure expression P.
(define (procedure-body p) (caddr p))

;; Return environment of procedure expression P.
(define (procedure-environment p) (cadddr p))

(define (enclosing-environment env) (cdr env))

;; Return the first frame of environment ENV.
(define (first-frame env)
  (if (eq? (car env) '*env*)
      (cadr env)
      (car env)))

;; Return the rest of the frames of environment ENV.
(define (rest-frame env)
  (if (eq? (car env) '*env*)
      (cddr env)
      (cdr env)))

;; Return implementation of underlying primitive procedure PROC.
(define (primitive-implementation proc) (cadr proc))

;; Return predicate of while expression EXP.
(define (while-predicate exp) (car exp))

;; Return body of while expression EXP.
(define (while-body exp) (cadr exp))

;; Syntax for Amb: (amb <e1> <e2> ... <e_n>)

;; Return choices of an AMB expression EXP.
(define (amb-choices exp) (cdr exp))

;;; Predicates

;; Is expression EXP tagged TAG?
(define (tagged-list? exp tag)
  (if (pair? exp)
      (eq? (car exp) tag)
      #f))

(define (self-evaluating? exp)
  (cond
   ((boolean? exp) #t)
   ((number? exp) #t)
   ((string? exp) #t)
   (else #f)))

(define (quoted? exp)
  (tagged-list? exp 'quote))

(define (variable? exp) (symbol? exp))

(define (assignment? exp)
  (tagged-list? exp 'set!))

(define (definition? exp)
  (tagged-list? exp 'define))

(define (lambda? exp) (tagged-list? exp 'lambda))

(define (if? exp) (tagged-list? exp 'if))

(define (begin? exp) (tagged-list? exp 'begin))

(define (last-exp? seq) (null? (cdr seq)))

;; Is expression EXP a application expression, that is (<operand> <operands>)?
(define (application? exp) (pair? exp))

(define (no-operands? ops) (null? ops))

(define (cond? exp) (tagged-list? exp 'cond))

(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))

;; Syntax for extended cond: (cond ((<clause>) => <procedure-which-tackes-1-arg>))

(define (cond-extended-syntax? clause)
  (and (pair? clause)
       (= (length clause) 3)
       (eq? (cadr clause) '=>)))

;; Syntax for named-let: (let <variable> <bindings> <body>).  Also see Info node
;; `(guile) while do'

(define (let-named-syntax? exp)
  (not (pair? (car exp))))

(define (true? x)
  (not (eq? x #f)))

(define (false? x)
  (eq? x #f))

(define (compound-procedure? p)
  (tagged-list? p 'procedure))

(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))

(define (let? exp) (tagged-list? exp 'let))

;; Return name of the variable in unbind! expression EXP.
(define (unbind-variable-name exp) (cadr exp))

(define (amb? exp) (tagged-list? exp 'amb))

;;; Mutators

;; Set variable VAR to value VAL in environment ENV.
(define (set-variable-value! var val env)
  (cond
   ((eq? env empty-frame)
    (error "Unbound variable -- SET-VARIABLE-VALUE!" var))
   ((assoc var (first-frame env))
    => (lambda (binding) (set-cdr! binding val)))
   (else
    (set-variable-value! var val (rest-frame env)))))

;; Define variable VAR to value VAL in environment ENV.
(define (define-variable! var val env)
  (set-car! (cdr env)
	    (assoc-set! (first-frame env) var val)))

;;; General Procedures

;; Return a environment by adding variables and values to environment BASE-ENV.
(define (extend-environment variables values base-env)
  (make-environment
    (cons (make-frame variables values) (cdr base-env))))

;; Lookup value of variable VAR in ENV.
(define (lookup-variable-value var env)
  (cond
   ((eq? env empty-frame)
    (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var))
   ((assoc var (first-frame env))
    => (lambda (binding)
	 (define var (car binding))
	 (define val (cdr binding))
	 (if (not (eq? val '*unassigned*))
	     val
	     (error "Unassigned variable -- LOOKUP-VARIABLE-VALUE" var))))
   (else
    (lookup-variable-value var (rest-frame env)))))

;; Return a list of names of primitive procedure.
(define (primitive-procedure-names)
  (map car primitive-procedures))

;; Return a list of objects representing primitive procedure's implementation.
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (cadr proc)))
       primitive-procedures))

;;; Transformers

;; Transform sequence of expression SEQ into single expression using `begin' if
;; necessary.
(define (sequence->exp seq)
  (cond ((null? seq) seq)
        ((last-exp? seq) (first-exp seq))
        (else (make-begin seq))))

(define (expand-clauses clauses)
  (if (null? clauses)
      #f                          ;no else clause
      (let ((first (car clauses))
	    (rest (cdr clauses)))
	(cond
	 ((cond-else-clause? first)
	  (if (null? rest)
	      (sequence->exp (cond-actions first))
              (error "ELSE clause isn't last -- COND->IF"
                     clauses)))
	 ((cond-extended-syntax? first)
	  (make-if (cond-extended-predicate first)
		   (list (cond-extended-action first)
			 (cond-extended-predicate first))
		   (expand-clauses rest)))
	 (else
	  (make-if (cond-predicate first)
		   (sequence->exp (cond-actions first))
		   (expand-clauses rest)))))))

;; Tranform a cond expression EXP into if expression.
(define (cond->if exp)
  (expand-clauses (cond-clauses exp)))

;; Scan-out all defines in procedure body PROC-BODY.
;;
;; Transform a procedure body from:
;;
;; (lambda (vars)
;;   (define u <e1>)
;;   (define v <e2>)
;;   <e3>)
;;
;; into:
;; (lambda (vars)
;;   (let ((u '*unassigned*)
;;	   (v '*unassigned*))
;;     (set! u <e1>)
;;     (set! v <e2>)
;;     <e3>))
;;
;; This will make our evaluator to treat all internally defined names in a truly
;; simultaneous scope -- in a block structure, the scope of all local names is
;; the entire procedure body in which the `define' is evaluated.
(define (scan-out-defines proc-body)
  ;; Transform define expression EXP with variables VARS and values VALUES into
  ;; a let expression.
  (define (define->let vars values exp)
    (if (or (null? vars) (null? values))
	exp
	(define->let
	  (cdr vars)
	  (cdr values)
	  (let-append (car vars) (car values) exp))))

  ;; Scan procedure body BODY for `defines' and accumulate them in VARS, VALUES
  ;; and FINAL-BODY.
  (define (scan body vars values final-body)
    (if (null? body)
	(list vars values (reverse final-body)) ;O(2n) is atrocious
	(let ((first (car body))
	      (rest (cdr body)))
	  (if (not (definition? (car body)))
	      (scan rest vars values (cons first final-body))
	      (scan rest
		    (cons (definition-variable first) vars)
		    (cons (definition-value first) values)
		    final-body)))))

  (let* ((tmp-list (scan proc-body '() '() '()))
	 (vars (car tmp-list))
	 (values (cadr tmp-list))
	 (final-body (caddr tmp-list)))
    (if (and (null? vars) (null? values))
	final-body
	;; Apply accepts a list.  This bug was found by Oavis at
	;; <https://www.inchmeal.io/sicp/ch-4/ex-4.16>
	(list (append (define->let vars values '()) final-body)))))

;; By Eli: <https://eli.thegreenplace.net/2007/12/06/sicp-sections-411-412>,
;; earlier I was using a hand-made iterative process.

;; Tranform let expression EXP into a combination.
(define (let->combination exp)
  ;; TODO 2021-09-11: Cleanup!
  (if (let-named-syntax? exp)
      (let* ((name (car exp))
	     (var-list (let-varlist (cdr exp)))
	     (var (car var-list))
	     (expr (cadr var-list)))
	(sequence->exp
	 (list (make-define (cons name var) (let-body (cdr exp)))
	       (cons name expr))))
      (let* ((var-list (let-varlist exp))
 	     (var (car var-list))
	     (expr (cadr var-list)))
	(cons (make-lambda var (let-body exp)) expr))))

;; Transform let* expression EXP into nested lets.
(define (let*->nested-let exp)
  (define (rec var-list body)
    (if (null? var-list)
	body
	(make-let (list (car var-list)) (rec (cdr var-list) body))))
  (rec (car exp)
       (cadr exp)))

;; Tranform letrec expression EXP into let expression.
(define (letrec->let exp)
  (define (iter vars values exp)
    (if (or (null? vars) (null? values))
	exp
	(iter (cdr vars)
	      (cdr values)
	      (let-append (car vars) (car values) exp))))
  (let ((varlist (let-varlist exp)))
    (append (iter (car varlist) (cadr varlist) '())
	    (cdr exp))))

;; Syntax for while: (while <predicate> <body>)

;; Transform a `while' expression EXP into `if' expression.
(define (while->combination exp)
  (sequence->exp
   (list
    (make-define
     (list 'iter)
     (list (make-if
	    (while-predicate exp)
	    (sequence->exp (list (while-body exp) '(iter)))
	    #t)))
    '(iter))))

;;; Apply

;; Used in-case of applying primitive Scheme procedures.
(define apply-in-underlying-scheme apply)

(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme
   (primitive-implementation proc) args))

;; Execute procedure PROC with arguments ARGS.
(define (execute-application proc args succeed fail)
  (cond
   ((primitive-procedure? proc)
    (succeed (apply-primitive-procedure proc args) fail))
   ((compound-procedure? proc)
    ((procedure-body proc)
     (extend-environment
      (procedure-parameters proc)
      args
      (procedure-environment proc))
     succeed
     fail))
   (else
    (error "Unknown procedure type -- EXECUTE-APPLICATION" proc))))

;;; Eval

;; Analyze a self-evaluating expression EXP.
(define (analyze-self-evaluating exp)
  (lambda (env succeed fail)
    (succeed exp fail)))

;; Analyze a quoted (i.e. (quote <exp>)) expression EXP.
(define (analyze-quoted exp)
  (let ((qval (text-of-quotation exp)))
    (lambda (env succeed fail)
      (succeed qval fail))))

;; Analyze a variable expression EXP.
(define (analyze-variable exp)
  (lambda (env succeed fail)
    (succeed (lookup-variable-value exp env)
             fail)))

;; Analyze a definition expression EXP.
(define (analyze-definition exp)
  (let ((var (definition-variable exp))
        (vproc (analyze (definition-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)
               (define-variable! var val env)
               (succeed 'ok fail2))
             fail))))

;; Analyze a assignment expression EXP.
(define (analyze-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc
       env
       ;; If assignment fails, then put back the `old-value'.
       (lambda (val fail2)
         (let ((old-value (lookup-variable-value var env)))
           (set-variable-value! var val env)
           (succeed 'ok
		    (lambda ()
		      (set-variable-value! var old-value env)
		      (fail2)))))
       fail))))

;; Analyze an permanent assignment expression EXP.
(define (analyze-permanent-assignment exp)
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc
       env
       ;; Unlike `analyze-assignment', don't keep note of `old-value'.
       (lambda (val fail2)
         (set-variable-value! var val env)
         (succeed 'ok fail2))
       fail))))

;; Analyze an if expression EXP.
(define (analyze-if exp)
  (let ((pproc (analyze (if-predicate exp)))
        (cproc (analyze (if-consequent exp)))
        (aproc (analyze (if-alternative exp))))
    (lambda (env succeed fail)
      (pproc env
             ;; Success continuation for evaluating the predicate
             ;; to obtain pred-value
             (lambda (pred-value fail2)
               (if (true? pred-value)
                   (cproc env succeed fail2)
                   (aproc env succeed fail2)))
             ;; Failure continuation for evaluating the predicate
             fail))))

;; Analyze an sequence of expressions EXPS.
(define (analyze-sequence exps)
  (define (sequentially a b)
    (lambda (env succeed fail)
      (a env
         ;; Success continuation for calling a
         (lambda (a-value fail2)
           (b env succeed fail2))
         ;; Failure continuation for calling a
         fail)))

  (define (loop first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (loop (sequentially first-proc (car rest-procs))
              (cdr rest-procs))))

  (let ((procs (map analyze exps)))
    (if (null? procs)
        (error "Empty sequence -- ANALYZE-SEQUENCE"))
    (loop (car procs) (cdr procs))))

;; FIXME 2021-09-19: Simultaneous definition are still undefined!
(define (analyze-lambda exp)
  (let ((vars (lambda-parameters exp))
        (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
    (lambda (env succeed fail)
      (succeed (make-procedure vars bproc env)
               fail))))

;; Analyze an begin expression EXP.
(define (analyze-begin exp)
  (let ((bproc (analyze-sequence (begin-actions exp))))
    (lambda (env succeed fail)
      (succeed (bproc env succeed fail) fail))))

;; Get list of args for argument procedures APROCS in enviornment ENV with
;; SUCCEED and FAIL as success and failure continuation.
(define (get-args aprocs env succeed fail)
  (if (null? aprocs)
      (succeed '() fail)
      ((car aprocs)
       env
       ;; success continuation for this aproc
       (lambda (arg fail2)
         (get-args (cdr aprocs)
                   env
                   ;; success continuation for recursive
                   ;; call to get-args
                   (lambda (args fail3)
                     (succeed (cons arg args) fail3))
                   fail2))
       fail)))

;; Analyze an application expression EXP.
(define (analyze-application exp)
  (let ((fproc (analyze (operator exp)))
        (aprocs (map analyze (operands exp))))
    (lambda (env succeed fail)
      (fproc env
	     (lambda (proc fail2)
               (get-args aprocs
			 env
			 (lambda (args fail3)
			   (execute-application
			    proc args succeed fail3))
			 fail2))
	     fail))))

;; Analyze an `cond' expression EXP.
(define (analyze-cond exp)
  (lambda (env succeed fail)
    ((analyze-if (cond->if exp)) env succeed fail)))

;; Analyze an `or' expression EXP.
(define (analyze-or exp)
  (lambda (env succeed fail)
    (define (iter aprocs previous-result)
      (if (null? aprocs)
	  (succeed previous-result fail)
	  (let ((result ((car aprocs) env succeed fail)))
	    (if result
		(succeed result fail)
		(iter (cdr aprocs) result)))))
    ;; NOTE 2021-09-14: We can optimize it even further, as we don't have to
    ;; analyze expression after first #t.
    (iter (map analyze (operands exp))
	  #f)))

;; Analyze an `and' expression EXP.
(define (analyze-and exp)
  (lambda (env succeed fail)
    (define (iter aprocs previous-result)
      (if (null? aprocs)
	  (succeed previous-result fail)
	  (let ((result ((car aprocs) env succeed fail)))
	    (if (not result)
		(succeed #f fail)
		(iter (cdr aprocs) result)))))
    ;; NOTE 2021-09-14: We can optimize it even further, as we don't have to
    ;; analyze expression after first #f.
    (iter (map analyze (operands exp))
	  #t)))

;; Analyze an `let' expression EXP.
(define (analyze-let exp)
  (analyze (let->combination (operands exp))))

;; Analyze an `let*' expression EXP.
(define (analyze-let* exp)
  (analyze (let*->nested-let (operands exp))))

;; Analyze an `letrec' expression EXP.
(define (analyze-letrec exp)
  (analyze (letrec->let (operands exp))))

;; Analyze an `while' expression EXP.
(define (analyze-while exp)
  (let ((aproc (analyze (while->combination (operands exp)))))
    (lambda (env succeed fail)
      (succeed (aproc env succeed fail) fail))))

;; Syntax for 'unbind!': (unbind! <symbol>)

;; Unbind variable VAR in environment ENV.
(define (unbind-variable! var env)
  (set-car! (cdr env)
	    (assoc-remove! (first-frame env) var)))

;; `Unbind!' name was coined by Oavis at:
;; <https://www.inchmeal.io/sicp/ch-4/ex-4.15.html>

;; Remove the binding of symbol-expression EXP from exvironment ENV.
(define (analyze-unbind! exp)
  (lambda (env succeed fail)
    (succeed (unbind-variable! (unbind-variable-name exp) env)
	     fail)))

;; Analyze an Amb expression EXP.
(define (analyze-amb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      ;; Analyze next choice in list of choices CHOICES.
      (define (try-next choices)
        (if (null? choices)
            (fail)
            ((car choices)
	     env
             succeed
             (lambda ()
               (try-next (cdr choices))))))

      (try-next cprocs))))

;; Install of procedures which are used in analyzing expressions.
(define (install-analyze-package)
  (put 'analyze 'quote analyze-quoted)
  (put 'analyze 'set! analyze-assignment)
  (put 'analyze 'permanent-set! analyze-permanent-assignment)
  (put 'analyze 'define analyze-definition)
  (put 'analyze 'lambda analyze-lambda)
  (put 'analyze 'if analyze-if)
  (put 'analyze 'begin analyze-begin)
  (put 'analyze 'cond analyze-cond)
  (put 'analyze 'or analyze-or)
  (put 'analyze 'and analyze-and)
  (put 'analyze 'let analyze-let)
  (put 'analyze 'let* analyze-let*)
  (put 'analyze 'letrec analyze-letrec)
  (put 'analyze 'while analyze-while)
  (put 'analyze 'unbind! analyze-unbind!)
  (put 'analyze 'amb analyze-amb))

;; Return the syntactic analysis of expression EXP.
(define (analyze exp)
  (cond
   ((self-evaluating? exp)
    (analyze-self-evaluating exp))
   ((variable? exp) (analyze-variable exp))
   ((get 'analyze (operator exp))
    => (lambda (proc) (proc exp)))
   ((application? exp) (analyze-application exp))
   (else
    (error "Unknown expression type -- ANALYZE" exp))))

;; Evaluate expression EXP in enviornment ENV.
(define (ambeval-eval exp env succeed fail)
  ((analyze exp) env succeed fail))

;;; REPL

(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))

(define (announce-output string)
  (newline) (display string) (newline))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)
                     '<procedure-env>))
      (display object)))

;; Run a Read-Eval-Print-Loop.
(define (driver-loop)
  (define (internal-loop try-again)
    (prompt-for-input input-prompt)
    (let ((input (read)))
      (if (eq? input 'try-again)
          (try-again)
          (begin
            (newline)
            (display ";;; Starting a new problem ")
            (ambeval-eval
	     input
             the-global-environment
             ;; ambeval success
             (lambda (val next-alternative)
               (announce-output output-prompt)
               (user-print val)
               (internal-loop next-alternative))
             ;; ambeval failure
             (lambda ()
               (announce-output
                ";;; There are no more values of")
               (user-print input)
               (driver-loop)))))))
  (internal-loop
   (lambda ()
     (newline)
     (display ";;; There is no current problem")
     (driver-loop))))

(define empty-frame (make-frame '() '()))

(define the-empty-environment (make-environment empty-frame))

(define (setup-environment)
  (let ((initial-env
	 (extend-environment (primitive-procedure-names)
			     (primitive-procedure-objects)
			     the-empty-environment)))
    (define-variable! #t #t initial-env)
    (define-variable! #f #f initial-env)
    (install-analyze-package)
    initial-env))

(define the-global-environment (setup-environment))

[-- Attachment #2.3: Test suite --]
[-- Type: text/plain, Size: 6346 bytes --]

;;; Test suite for non-deterministic evaluator

;; Most if not all test are derived from Eli's work at:
;; <https://github.com/eliben/code-for-blog/tree/master/2007/sicp>

(use-modules (srfi srfi-64))
(use-modules (sicp ch-4 ambeval))

(define (interpret exp)
  (ambeval-eval
   exp
   the-global-environment
   (lambda (val next-alternative) val)
   (lambda () 'dead-end)))

(test-begin "test-self-eval")
(test-equal 19 (interpret 19))
(test-equal "Hello Scheme!" (interpret "Hello Scheme!"))
(test-equal 666666666222 (interpret 666666666222))
(test-end "test-self-eval")


(test-begin "test-expr")
(test-equal 19 (interpret '(+ 10 9)))
(test-equal 2 (interpret '(* (- 2 3) (- 4 6))))
(test-equal 11 (interpret '(+ (* 1 2) (/ 6 2) (* (- 5 4) 2 3))))
(test-end "test-expr")


(test-begin "test-quoted")
(test-eq 'abracadabra (interpret '(quote abracadabra)))
(test-eq 'hello (interpret '(quote hello)) 'hello)
(test-equal '(jay wizz 2 watt) (interpret '(quote (jay wizz 2 watt))))
(test-end "test-quoted")


(test-begin "test-conditionals")
(test-assert (interpret '(if (= 4 5) #f 1)))
(test-assert (interpret '(if (= 5 5) 1 #f)))
(test-assert (interpret '(if #f #f #t)))
(test-assert (interpret '(if 1 #t #f)))

;; note: -cond- also tests how -begin- works
(test-assert (interpret '(cond (#f #f) (else #t))))
(test-assert (interpret '(cond (#t #t) (else #f))))
(test-assert
    (interpret
     '(cond
       ((= 5 6) #f)
       ((= 4 5) #f)
       ((= 5 5) #t)
       (else #f))))
(test-assert
    (interpret
     '(cond
       ((= 5 6) #f)
       ((= 4 5) #f)
       ((= 51 5) #f)
       (else (= 1 1)))))
(test-end "test-conditionals")


(test-begin "test-or-and")
(test-assert (not (interpret '(or))))
(test-assert (interpret '(or 1 2 3)))
(test-equal 3 (interpret '(or #f #f 3)))
(test-assert (not (interpret '(or #f #f))))

(test-assert (interpret '(and)))
(test-equal 3 (interpret '(and 1 2 3)))
(test-equal 3 (interpret '(and #t #t 3)))
(test-assert (not (interpret '(and #f #f))))
(test-end "test-or-and")


(test-begin "test-vars")
(interpret '(define num1 12))
(interpret '(define num2 5))

(test-equal 12 (interpret 'num1))
(test-assert (interpret '(= num1 12)))
(test-equal 14 (interpret '(+ num1 2)))
(test-equal 17 (interpret '(+ num1 num2)))
(test-assert (not (interpret '(= num1 num2))))

(interpret '(set! num2 10))
(interpret '(set! num1 (+ 10 num2)))
(test-equal 30 (interpret '(+ num1 num2)))
(test-end "test-vars")


(test-begin "test-procedure")
(interpret '(define (sum a b) (+ a b)))
(interpret '(define (average x y) (/ (sum x y) 2)))
(interpret '(define xx 10))
(interpret '(define yy 20))

(test-equal 6 (interpret '(sum 2 4)))
(test-equal 15 (interpret '(average xx yy)))

;; applying a lambda directly
(test-equal 20 (interpret '((lambda (x y) (+ x y)) 15 5)))

;; define an explicit lambda
(interpret '(define lsum (lambda (x y) (+ x y))))
(test-equal 23 (interpret '(lsum 11 12)))

(interpret '(set! lsum (lambda (x y) (- x y))))
(test-equal -1 (interpret '(lsum 11 12)))

;; recursive procedure
(interpret
 '(define (rsum x y)
    (if (= y 0)
	x
	(rsum (+ x 1) (- y 1)))))

(test-equal 11 (interpret '(rsum 5 6)))
(test-equal 6 (interpret '(rsum 0 6)))
(test-equal 6 (interpret '(rsum 6 0)))

;; returning a procedure from another procedure
(interpret '(define (make-adder-proc x) (lambda (y) (+ x y))))
(interpret '(define add2 (make-adder-proc 2)))

(test-equal 12 (interpret '(add2 xx)))
(test-equal 14 (interpret '((make-adder-proc 4) 10)))

;; accepting a procedure as an argument
(interpret '(define (apply-twice proc val) (proc (proc val))))

(test-equal 104 (interpret '(apply-twice add2 100)))
(test-equal 10000 (interpret '(apply-twice (lambda (x) (* x x)) 10)))

;; Compose takes two procedures, and returns a procedure that is their
;; composition.
(interpret '(define (compose f g) (lambda (x) (f (g x)))))
(interpret '(define (square x) (* x x)))
(interpret '(define (inc x) (+ x 1)))

(test-equal 121 (interpret '((compose square inc) 10)))
(test-equal 101 (interpret '((compose inc square) 10)))
(test-end "test-procedure")


(test-begin "test-let")
(test-equal 6 (interpret '(let ((a 1) (b 2) (c 3)) (+ a b c))))
(interpret '(define (abc a b) (let ((d (+ a b))) (+ d d))))
(test-equal 20 (interpret '(abc 6 4)))
(test-end "test-let")


(test-begin "test-let*")
(test-equal 39
  (interpret
   '(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))))
(test-end "test-let*")


(test-begin "test-named-let")
(interpret
 '(define (fib n)
    (let fib-iter ((a 1) (b 0) (count n))
      (if (= count 0)
	  b
	  (fib-iter (+ a b) a (- count 1))))))
(test-equal 13 (interpret '(fib 7)))
(test-equal 21 (interpret '(fib 8)))
(test-end "test-named-let")


(test-begin "test-letrec")
(interpret
 '(define (findout32 x)
    (letrec ((even?
	      (lambda (n)
		(if (= n 0)
		    #t
		    (odd? (- n 1)))))
	     (odd?
	      (lambda (n)
		(if (= n 0)
		    #f
		    (even? (- n 1))))))
      (cond
       ((even? x) 20)
       ((odd? x) 30)
       (else 40)))))

(test-equal 20 (interpret '(findout32 4)))
(test-equal 30 (interpret '(findout32 5)))
(test-end "test-letrec")


(test-begin "test-while")
(interpret '(define xx 5))
(interpret '(define yy 6))
(interpret
 '(while (> xx 0)
    (begin
      (set! xx (- xx 1))
      (set! yy (+ yy 1)))))

(test-equal 0 (interpret 'xx))
(test-equal 11 (interpret 'yy))
(test-end "test-while")


(test-begin "test-unbind")
(interpret '(define abc 12))
(test-equal 12 (interpret 'abc))
(interpret '(unbind! abc))
(test-error #t (interpret 'abc))
(test-end "test-unbind")


(test-begin "test-internal-defs")
(interpret
 '(define (kkk a b c)
    (define u (+ a b))
    (define v (+ b c))
    (* u v c)))

(test-equal 45 (interpret '(kkk 1 2 3)))

;; mutually recursive internal definitions
(interpret
 '(define (findout12 x)
    (define (even? n)
      (if (= n 0)
          #t
          (odd? (- n 1))))
    (define (odd? n)
      (if (= n 0)
          #f
          (even? (- n 1))))
    (cond
     ((even? x) 20)
     ((odd? x) 30)
     (else 40))))

(test-equal 20 (interpret '(findout12 4)))
(test-equal 30 (interpret '(findout12 5)))

;; usage before definition
(interpret
 '(define (kkk12 x)
    (define p (+ x x))
    (set! p (- x (garfield12 p)))
    (define (garfield12 x) (* x 2))
    p))

(test-equal -30 (interpret '(kkk12 10)))
(test-end "test-internal-defs")

[-- Attachment #2.4: Letrec log --]
[-- Type: text/plain, Size: 760 bytes --]

%%%% Starting test test-letrec
Group begin: test-letrec
Test begin:
  source-file: "sicp/ch-4/test/ambeval-test.scm"
  source-line: 190
  source-form: (test-equal 20 (interpret (quote (findout32 4))))
Test end:
  result-kind: fail
  actual-value: #f
  actual-error: (misc-error #f "~A ~S" ("Unassigned variable -- LOOKUP-VARIABLE-VALUE" odd?) #f)
  expected-value: 20
Test begin:
  source-file: "sicp/ch-4/test/ambeval-test.scm"
  source-line: 191
  source-form: (test-equal 30 (interpret (quote (findout32 5))))
Test end:
  result-kind: fail
  actual-value: #f
  actual-error: (misc-error #f "~A ~S" ("Unassigned variable -- LOOKUP-VARIABLE-VALUE" odd?) #f)
  expected-value: 30
Group end: test-letrec
# of expected passes      50
# of unexpected failures  2

[-- Attachment #3: Type: text/plain, Size: 112 bytes --]

-------------------- End of forwarded message --------------------

-- 
Utkarsh Singh
https://utkarshsingh.xyz/

  reply	other threads:[~2021-09-20  4:16 UTC|newest]

Thread overview: 4+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-09-20  3:15 Undefined simultaneous definitions Utkarsh Singh
2021-09-20  4:16 ` Utkarsh Singh [this message]
     [not found]   ` <CAGua6m39tyjgsA+PTc5+uzuOCN6O42ztQ+vibkcq7Jt98k7MYw@mail.gmail.com>
     [not found]     ` <878rzrfqti.fsf@gmail.com>
     [not found]       ` <CAGua6m33sS5NNqFE41LM6zhD7sGWimFUf0ZS8t_2=eobpRcgiQ@mail.gmail.com>
2021-09-20 13:18         ` [Utkarsh Singh] " Utkarsh Singh
2021-09-23  7:06           ` Utkarsh Singh

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://www.gnu.org/software/guile/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=877dfbankk.fsf@gmail.com \
    --to=utkarsh190601@gmail.com \
    --cc=guile-user@gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).