commit 7d6e880fb77a5c9d2151a38aef1f4322ecbfdfce
parent 6e824bcec28a8f7297d540bc37626b2d3393610a
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Mon, 22 Jul 2024 11:32:12 +0300
Finish copying the SICP REPL almost verbatim from the book, for use as template for the exercises.
Diffstat:
3 files changed, 411 insertions(+), 286 deletions(-)
diff --git a/sicp/solutions/chapter-4/original-repl.scm b/sicp/solutions/chapter-4/original-repl.scm
@@ -11,65 +11,106 @@
)
(import
(rename (scheme base) (apply scheme:base:apply))
- (prefix (scheme cxr) scheme:cxr:)
- (prefix (scheme read) scheme:read:)
- (prefix (scheme write) scheme:write:)
+ (scheme cxr)
+ (scheme read)
+ (scheme write)
+ (srfi srfi-1)
(srfi srfi-9)
(srfi srfi-64)
+ (system vm trace)
+
(ice-9 match)
+ (ice-9 pretty-print)
(sicp utils)
)
(begin
+ ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
+ ;; using the host-variable `false` whose value is 'false, but we
+ ;; don't see it defined anywhere in the good book, so we need to
+ ;; define the host-variable false ourselves.
+ ;;
+ ;; In MIT Scheme, the one the SICP people seem to love to use for
+ ;; SICP, the values of `false` and `true` are #f and #t, #f being
+ ;; the only value that is falsituous and #t there for having a
+ ;; truthious value that has no other meaning other than being
+ ;; truthitiousic.
+ ;;
+ ;; ```
+ ;; # `scheme` is the MIT Scheme executable:
+ ;; $ guix shell mit-scheme -- scheme
+ ;; MIT/GNU Scheme running under GNU/Linux
+ ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
+ ;;
+ ;; Copyright (C) 2020 Massachusetts Institute of Technology
+ ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ ;;
+ ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
+ ;; Release 11.2 || SF || LIAR/x86-64
+ ;;
+ ;; 1 ]=> false
+ ;;
+ ;; ;Value: #f
+ ;;
+ ;; 1 ]=> true
+ ;;
+ ;; ;Value: #t
+ ;;
+ ;; 1 ]=>
+ ;; ```
+ (define false #f)
+ (define true #t)
+
(define (make-environment vars vals)
+ "A comfort procedure because calling extend on the-empty-environment is a PITA."
(extend-environment vars
vals
the-empty-environment))
+ ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
+ ;; host `apply`, and the guest `apply` differently. I define the
+ ;; host's `apply` to be the name used in the book.
+ (define apply-in-underlying-scheme scheme:base:apply)
+
;;; Start:
;;; 4.1.1
(define (eval exp env)
- (pp (list 'eval exp))
- (dp)
- (define eval-result
- (cond ((self-evaluating? exp)
- exp)
- ((variable? exp)
- (lookup-variable-value exp env))
- ((quoted? exp)
- (text-of-quotation exp))
- ((assignment? exp)
- (eval-assignment exp env))
- ((definition? exp)
- (eval-definition exp env))
- ((if? exp)
- (eval-if exp env))
- ((lambda? exp)
- (make-procedure
- (lambda-parameters exp)
- (lambda-body exp)
- env))
- ((begin? exp)
- (eval-sequence
- (begin-actions exp)
- env))
- ((cond? exp)
- (eval (cond->if exp) env))
- ((application? exp)
- (apply (eval (operator exp) env)
- (list-of-values
- (operands exp)
- env)))
- (else
- (error "Unknown expression type -- EVAL" exp))))
- (dpp `(eval-result ,eval-result))
- (dp)
- eval-result)
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((quoted? exp)
+ (text-of-quotation exp))
+ ((assignment? exp)
+ (eval-assignment exp env))
+ ((definition? exp)
+ (eval-definition exp env))
+ ((if? exp)
+ (eval-if exp env))
+ ((lambda? exp)
+ (make-procedure
+ (lambda-parameters exp)
+ (lambda-body exp)
+ env))
+ ((begin? exp)
+ (eval-sequence
+ (begin-actions exp)
+ env))
+ ((cond? exp)
+ (eval (cond->if exp) env))
+ ((application? exp)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env)))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
@@ -89,6 +130,14 @@
(error "Unknown procedure type -- APPLY"
procedure))))
+;;; Procedure arguments:
+
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
;;; Conditionals:
(define (eval-if exp env)
@@ -98,7 +147,6 @@
;;; Sequences:
-
(define (eval-sequence exps env)
(cond ((last-exp? exps)
(eval (first-exp exps) env))
@@ -109,8 +157,6 @@
;;; Assignments and definitions
-
-
(define (eval-assignment exp env)
(set-variable-value!
(assignment-variable exp)
@@ -119,17 +165,10 @@
'ok)
(define (eval-definition exp env)
- (dp `(eval-definition ,exp))
- (dp)
- (let ((def-var (definition-variable exp))
- (def-val (definition-value exp)))
- (dp `(definition-variable ,def-var))
- (dp `(definition-value ,def-val))
- (dp)
- (define-variable!
- (definition-variable exp)
- (eval (definition-value exp) env)
- env))
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
'ok)
;;; end 4.1.1
@@ -138,78 +177,82 @@
(define (self-evaluating? exp)
- (or (number? exp)
- (string? exp)))
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
(define (variable? exp) (symbol? exp))
- (define (quoted? exp) (tagged-list? exp 'quote))
- (define (text-of-quotation exp) (cadr exp))
+ (define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+ (define (text-of-quotation exp)
+ (cadr exp))
(define (tagged-list? exp tag)
- (and (pair? exp)
- (eq? (car exp) tag)))
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
- (define (assignment? exp) (tagged-list? exp 'set!))
- (define (assignment-variable exp) (cadr exp))
- (define (assignment-value exp) (scheme:cxr:caddr exp))
+ (define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+ (define (assignment-variable exp)
+ (cadr exp))
+
+ (define (assignment-value exp) (caddr exp))
(define (definition? exp)
(tagged-list? exp 'define))
+
(define (definition-variable exp)
- (cond
- ((symbol? (cadr exp))
- (cadr exp))
- (else
- (scheme:cxr:caadr exp))))
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+
(define (definition-value exp)
- (cond
- ((symbol? (cadr exp))
- (scheme:cxr:caddr exp))
- (else
- (let ((formal-parameters (scheme:cxr:cdadr exp))
- (body (cddr exp)))
- (dp `(formal-parameters ,formal-parameters))
- (dp `(body ,body))
- (dp)
- (make-lambda formal-parameters
- body)))))
-
- (define (lambda? exp) (tagged-list? exp 'lambda))
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda
+ (cdadr exp) ; formal-parameters
+ (cddr exp)))) ; body
+
+ (define (lambda? exp)
+ (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
+
(define (make-lambda parameters body)
- (let ((our-lambda `(lambda ,parameters ,@body)))
- (dp `(our-lambda ,our-lambda))
- our-lambda))
+ (cons 'lambda (cons parameters body)))
(define (if? exp) (tagged-list? exp 'if))
(define (if-predicate exp) (cadr exp))
- (define (if-consequent exp) (scheme:cxr:caddr exp))
+ (define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
- (match exp
- (`(if ,p ,c ,a)
- a)
- (`(if ,p ,c)
- 'false)
- (otherwise (error "Malformed if:" otherwise)))
- ;; (cond
- ;; ((not (null? (scheme:cxr:cdddr exp)))
- ;; (scheme:cxr:cdddr exp)
- ;; 'false))
- )
- (define (make-if predicate consequent alternative)
- (list 'if predicate consequent alternative))
-
- (define (begin? exp) (tagged-list? exp 'begin))
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+ (define (make-if predicate
+ consequent
+ alternative)
+ (list 'if
+ predicate
+ consequent
+ alternative))
+
+ (define (begin? exp)
+ (tagged-list? exp 'begin))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-exps seq) (cdr seq))
+
(define (sequence->exp seq)
- (cond
- ((null? seq) seq)
- ((last-exp? seq) (first-exp seq))
- (else (make-begin seq))))
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+
(define (make-begin seq) (cons 'begin seq))
(define (application? exp) (pair? exp))
@@ -219,240 +262,264 @@
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
- (define (cond? exp) (tagged-list? exp 'cond))
+ (define (cond? exp)
+ (tagged-list? exp 'cond))
(define (cond-clauses exp) (cdr exp))
- (define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else))
- (define (cond-predicate clause) (car clause))
- (define (cond-actions clause) (cdr clause))
- (define (cond->if exp) (expand-clauses (cond-clauses exp)))
+ (define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+ (define (cond-predicate clause)
+ (car clause))
+ (define (cond-actions clause)
+ (cdr clause))
+ (define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
- (cond
- ((null? clauses)
- 'false
- (let ((first-clause (car clauses))
- (rest-of-clauses (cdr clauses)))
- (cond
- ((cond-else-clause? first-clause)
- (cond
- ((null? rest-of-clauses)
- (sequence->exp
- (cond-actions first-clause)))
- (else
- (error "ELSE clause isn't last: COND->IF"))))
- (else
- (make-if (cond-predicate first-clause)
- (sequence->exp (cond-actions first-clause))
- (expand-clauses rest-of-clauses))))))))
+ (if (null? clauses)
+ 'false
+ (let ((first (car clauses))
+ (rest (cdr clauses)))
+ (if (cond-else-clause? first)
+ (if (null? rest)
+ (sequence->exp
+ (cond-actions first))
+ (error "ELSE clause isn't last: COND->IF"
+ clauses))
+ (make-if (cond-predicate first)
+ (sequence->exp
+ (cond-actions first))
+ (expand-clauses
+ rest))))))
;;; end 4.1.2
;;; 4.1.3
- ;; The symbol false is the only false in the language.
-
+ ;; XXX: By default, false's value is #f, which is the only true
+ ;; false. All others are fake and would have the truthitousness
+ ;; property. Consult `info r7rs-small` or `C-h
+ (define (true? x)
+ (not (eq? x false)))
- (define (true? x) (not (false? x)))
- (define (false? x) (eq? x 'false))
-
- (define (make-frame variables values) (cons variables values))
- (define (frame-variables frame) (car frame))
- (define (frame-values frame) (cdr frame))
- (define (add-binding-to-frame! var val frame)
- (set-car! frame (cons var (frame-variables frame)))
- (set-cdr! frame (cons val (frame-values frame))))
-
- (define (define-variable! var val env)
- "Add variable VAR with value VAL to environment ENV."
-
- ;; We will CHANGE only the first frame
- (let ((frame (first-frame env)))
- (define (scan vars vals)
- (cond ((null? vars)
- (add-binding-to-frame! var
- val
- frame))
- ((eq? var (car vars))
- (set-car! vals val))
- (else (scan (cdr vars)
- (cdr vals)))))
- (dpp `(frame-values ,(frame-values frame)))
- (dp)
- (scan (frame-variables frame)
- (frame-values frame))))
-
- (define (enclosing-environment env) (cdr env))
- (define (first-frame env) (car env))
- (define the-empty-environment '())
+ (define (false? x)
+ (eq? x false))
(define (make-procedure parameters body env)
(list 'procedure parameters body env))
(define (compound-procedure? p)
(tagged-list? p 'procedure))
(define (procedure-parameters p) (cadr p))
- (define (procedure-body p) (scheme:cxr:caddr p))
- (define (procedure-environment p) (scheme:cxr:cadddr p))
+ (define (procedure-body p) (caddr p))
+ (define (procedure-environment p) (cadddr p))
+
+ (define (enclosing-environment env) (cdr env))
+ (define (first-frame env) (car env))
+ (define the-empty-environment '())
+
+ (define (make-frame variables values)
+ (cons variables values))
+ (define (frame-variables frame) (car frame))
+ (define (frame-values frame) (cdr frame))
+ (define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
(define (extend-environment vars vals base-env)
- (let ((vars-length (length vars))
- (vals-length (length vals)))
- (cond
- ((= vars-length vals-length)
- (cons (make-frame vars vals) base-env))
- ((< vars-length vals-length)
- (error "Too many arguments supplied:" vars vals))
- (else
- (error "Too few arguments supplied:" vars vals)))))
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied"
+ vars
+ vals)
+ (error "Too few arguments supplied"
+ vars
+ vals))))
(define (lookup-variable-value var env)
(define (env-loop env)
- (dpp `(env ,env))
- (dp)
(define (scan vars vals)
- (dpp `(vars ,vars vals ,vals))
- (dp)
(cond ((null? vars)
(env-loop
(enclosing-environment env)))
((eq? var (car vars))
- (dpp `(car-of-vals ,(car vals)))
- (dp)
(car vals))
(else (scan (cdr vars)
(cdr vals)))))
- (cond
- ((eq? env the-empty-environment)
- (error "Unbound variable" var))
- (else
- (let ((frame (first-frame env)))
- (scan (frame-variables frame)
- (frame-values frame))))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
(env-loop env))
-
(define (set-variable-value! var val env)
- (define (env-lookup env)
+ ;; XXX: Just trying to see what it would look like if I just used named lets.
+ ;;
+ ;; (let loop-over-environments ((env env))
+ ;; (cond
+ ;; ((eq? env the-empty-enviornment)
+ ;; (error "Unbound variable: SET!" var))
+ ;; (else
+ ;; (let ((frame (first-frame env)))
+ ;; (let loop-over-frame ((vars (frame-variables frame))
+ ;; (vals (frame-values frame)))
+ ;; (cond
+ ;; ((null? vars)
+ ;; (loop-over-environments (enclosing-environment env)))
+ ;; ((eq? var (car vars))
+ ;; (set-car! vals val))
+ ;; (else
+ ;; (loop-over-frame ((cdr vars)
+ ;; (cdr vals))))))))))
+
+ (define (env-loop env)
(define (scan vars vals)
- (cond
- ((null? vars)
- (env-lookup
- (enclosing-environment env)))
- ((eq? var (car vars))
- (set-car! vals val))
- (else
- (scan (cdr vars)
- (cdr vals)))))
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
(if (eq? env the-empty-environment)
(error "Unbound variable: SET!" var)
(let ((frame (first-frame env)))
(scan (frame-variables frame)
(frame-values frame)))))
- (env-lookup env))
+ (env-loop env))
- (define (list-of-values exps env)
- (if (no-operands? exps)
- '()
- (cons (eval (first-operand exps) env)
- (list-of-values (rest-operands exps) env))))
+ (define (define-variable! var val env)
+ "Add a new variable VAR with value VAL in the top frame of environment ENV.
+
+If variable VAR already exists in the top frame, set VAR in the top
+frame to VAL."
+
+ ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
+ ;; don't remember. Maybe it is some sort of a joke?) only
+ ;; the first frame.
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame!
+ var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
;;; 4.1.4
(define (setup-environment)
- (let* ((primitive-procedures
- `((car ,car)
- (cdr ,cdr)
- (cons ,cons)
- (null? ,null?)))
- (primitive-procedure-names (map car primitive-procedures))
- (primitive-procedure-objects (map (lambda (proc)
- `(primitive ,(cadr proc)))
- primitive-procedures))
+ (dpp 'moo)
+ (let* (;; XXX: See bug below on the quoted (define
+ ;; primitive-procedures ...)
+ (primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
(initial-env
(extend-environment
- primitive-procedure-names
- primitive-procedure-objects
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
the-empty-environment)))
- (define-variable! 'true 'true initial-env)
- (define-variable! 'false 'false initial-env)
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
initial-env))
(define the-global-environment
- (setup-environment))
-
- (define (primitive-procedure? proc) (tagged-list? proc 'primitive))
- (define (primitive-implementation proc) (cadr proc))
+ (begin
+ (dpp 'moo)
+ (setup-environment)))
+
+ (define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+ (define (primitive-implementation proc)
+ (cadr proc))
+
+ ;; XXX: There is a bug here in SICP or GNU Guile or both.
+ ;; primitive-procedures is `#<unspecified>` when this library is
+ ;; being loaded.
+ '(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+
+ (define (primitive-procedure-names primitive-procedures)
+ (map car
+ primitive-procedures))
+
+ (define (primitive-procedure-objects primitive-procedures)
+ (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
(define (apply-primitive-procedure proc args)
- (scheme:base:apply
+ (apply-in-underlying-scheme
(primitive-implementation proc) args))
- (define input-prompt ";;; M-Eval input:")
+ (define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
(prompt-for-input input-prompt)
- (let loop ((input (scheme:read:read)))
-
- (when *debug* (pp (list 'input input)))
- (cond
- ((eof-object? input)
- (when *debug* (pp (list 'the-global-environment
- the-global-environment))))
- (else
- (when *debug* (pp (list 'the-global-environment
- the-global-environment)))
- (let* ((output (eval input the-global-environment)))
- (announce-output output-prompt)
- (user-print output))
- (prompt-for-input input-prompt)
- (loop (scheme:read:read))))))
+ (let ((input (read)))
+ (let ((output
+ (eval input
+ the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
(define (prompt-for-input string)
- (newline)
- (newline)
- (scheme:write:display string)
- (newline))
+ (newline) (newline)
+ (display string) (newline))
(define (announce-output string)
- (newline)
- (scheme:write:display string)
- (newline))
+ (newline) (display string) (newline))
(define (user-print object)
- (cond
- ((procedure? object)
- (let ((proc (list 'compound-procedure
- (procedure-parameters object)
- (procedure-body object)
- '<procedure-env>)))
- (when *debug* (pp proc))
- proc))
- (else
- (pretty-print object))))
+ (if (compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+ ;; XXX: Already defined above:
+ ;; (define the-global-environment
+ ;; (setup-environment))
(define (main args)
(match args
('()
(error "Arguments should have something rather than nothing."))
(`(,arg0)
- (scheme:write:display arg0)
+ (display arg0)
(newline))
(`(,arg0 "--debug")
- (scheme:write:display "DEBUG TURN ON!\n")
+ (display "DEBUG TURN ON!\n")
(set! *debug* #t))
(args (error "Unknown arguments:" args)))
- (eval '(define (x y)
- (cond
- ((null? x)
- y)
- (else
- (cons (car x)
- (append (cdr x)
- y)))))
- the-global-environment)
-
- (dp (list 'starting-with-the-global-environment: the-global-environment))
- (dp)
(driver-loop))
(define (run-internal-tests)
diff --git a/sicp/tests/chapter-4/original-repl-tests.scm b/sicp/tests/chapter-4/original-repl-tests.scm
@@ -1,6 +1,8 @@
(define-library (sicp tests chapter-4 original-repl-tests)
(import (scheme base)
+
(srfi srfi-64)
+
(prefix (sicp solutions chapter-4 original-repl) repl:)
(sicp utils))
@@ -8,7 +10,6 @@
(set! *debug* #t)
(test-begin "original-repl-tests")
-
(test-group "internal-tests"
(repl:run-internal-tests))
@@ -16,7 +17,7 @@
(repl:eval 1 '()))
(test-equal '()
- (repl:eval '(quote ()) '()))
+ (repl:eval '(quote ()) '()))
(test-equal 1
(repl:eval '(+ -1 2)
@@ -50,4 +51,21 @@
`((primitive ,+))
(repl:setup-environment))))
+ (test-equal 1
+ (repl:eval '((lambda (a b)
+ (+ a b))
+ -1 2)
+ (repl:extend-environment '(+)
+ `((primitive ,+))
+ (repl:setup-environment))))
+
+ (test-equal 1
+ (repl:eval '(begin
+ (define (plus a b)
+ (+ a b))
+ (plus -1 2))
+ (repl:extend-environment '(+)
+ `((primitive ,+))
+ (repl:setup-environment))))
+
(test-end "original-repl-tests")))
diff --git a/sicp/utils.scm b/sicp/utils.scm
@@ -1,13 +1,9 @@
(define-library (sicp utils)
- (import (scheme base)
- (scheme write)
-
- (ice-9 pretty-print)
-
- (srfi srfi-19))
(export
*debug*
accumulate
+ debug!
+ debug?
dp
dpp
enumerate-interval
@@ -15,26 +11,70 @@
flatmap
pp
)
+ (import (scheme base)
+ (scheme write)
+
+ (ice-9 pretty-print)
+
+ (srfi srfi-1)
+ (srfi srfi-19)
+ (srfi srfi-28)
+
+ ;;(prefix (guile) guile:)
+ (only (guile)
+ define*
+ define-syntax-rule
+ current-source-location))
(begin
(define *debug* #f)
+ (define* (debug! #:optional x)
+ (if x
+ (set! *debug* (not *debug*))
+ (set! *debug* x)))
+ (define (debug?) *debug*)
(define nil '())
- (define (dp . x)
- "Debug Print."
- (when *debug*
- (if (null? x)
- (newline)
- (begin (write (car x))
- (newline)
- (car x)))))
+ (define-syntax-rule (dp x)
+ ;; Debug Print.
+ (when (debug?)
+ (let* ((loc (current-source-location))
+ (line-number (cdr (assoc 'line loc eq?)))
+ (column-number (cdr (assoc 'column loc eq?)))
+ (x-val x))
+ (display line-number)
+ (display ":")
+ (display column-number)
+ (display ":")
+ (newline)
+ (write (quote x))
+ (newline)
+ (display " = " )
+ (newline)
+ (write x-val)
+ (display "\n\n")
+ x-val)))
- (define (dpp x)
- "Debug Pretty Print."
- (when *debug*
- (pretty-print x)
- x))
+ (define-syntax dpp
+ ;; Debug Pretty Print.
+ (syntax-rules ()
+ ((dpp x)
+ (when (debug?)
+ (let* ((loc (current-source-location))
+ (line-number (cdr (assoc 'line loc eq?)))
+ (column-number (cdr (assoc 'column loc eq?)))
+ (x-val x))
+ (display line-number)
+ (display ":")
+ (display column-number)
+ (display ":")
+ (newline)
+ (pretty-print (quote x))
+ (display "=> ")
+ (pretty-print x-val)
+ (newline)
+ x-val)))))
(define (pp x)
(pretty-print x))
