(defpackage :fwoar.lisp-sandbox.1
(:use :cl )
(:export ))
(in-package :fwoar.lisp-sandbox.1)
(defvar *trace-depth* 0)
(defclass bool () ())
(progn
(defvar true (make-instance 'bool))
(defmethod print-object ((o (eql true)) s)
(format s "#.~s" 'true)))
(progn
(defvar false (make-instance 'bool))
(defmethod print-object ((o (eql false)) s)
(format s "#.~s" 'false)))
(defmacro define ((name &rest args) &body body)
`(progn (defun ,name (,@args)
,@body)
(defparameter ,name (function ,name))))
(declaim (inline atom? symbol? string? number? char? boolean? vector?))
(define (atom? exp)
(atom exp))
(define (null? it)
(null it))
(define (symbol? exp)
(symbolp exp))
(define (number? exp)
(numberp exp))
(define (string? exp)
(stringp exp))
(define (char? exp)
(characterp exp))
(define (boolean? exp)
(or (eq exp false)
(eq exp true)))
(define (vector? exp)
(vectorp exp))
(define (eq? a b)
(eq a b))
(define (pair? it)
(consp it))
(define (set-cdr! it value)
(rplacd it value))
(defvar empty-begin 813)
(define (eprogn exps env)
(if (pair? exps)
(if (pair? (cdr exps))
(progn (evaluate (car exps) env)
(eprogn (cdr exps)
env))
(evaluate (car exps)
env))
empty-begin))
(define (evlis exps env)
(if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
()))
(define (wrong &rest args)
(error "~{~a~^ ~}" args))
(defvar env.init ())
(defvar env.global (cons nil env.init))
(defun key-eql (key)
(lambda (a b)
(eql (funcall key a)
(funcall key b))))
(defun do-adjoin (list item &rest r)
(cons item
(apply #'remove item list r)))
(define-modify-macro adjoinf (item &rest r) do-adjoin)
(defmacro definitial (name &optional (value nil value-p))
(if value-p
`(progn (adjoinf (cdr env.global)
(cons ',name ,value)
:test (key-eql #'car))
',name)
`(progn (adjoinf (cdr env.global)
(cons ',name '#:uninit)
:test (key-eql #'car))
',name)))
(defmacro defprimitive (name value arity)
`(definitial ,name
(lambda (values &optional env)
(if (= ,arity (length values))
(apply ',value values)
(wrong "incorrect arity" ',name ,arity values)))))
(defmacro defprimitive-bool (name value arity)
`(definitial ,name
(lambda (values &optional env)
(if (= ,arity (length values))
(if (apply ',value values)
true
false)
(wrong "incorrect arity" ',name ,arity values)))))
(define (extend env variables values)
(cond ((pair? variables)
(if (pair? values)
(cons (cons (car variables) (car values))
(extend env (cdr variables) (cdr values)))
(wrong "Too less values")))
((null? variables)
(if (null? values)
env
(wrong "Too much values")))
((symbol? variables) (cons (cons variables values) env))))
(define (invoke fn args)
(if (functionp fn)
(funcall fn args)
(wrong "Not a function" fn)))
(define (lookup id env)
(if (pair? env)
(if (eq? (caar env) id)
(cdar env)
(lookup id (cdr env)))
(wrong "No such binding" id)))
(define (make-function variables body env)
(lambda (values)
(eprogn body
(extend env
variables
values))))
(define (update! id env value)
(if (pair? env)
(if (eq? (caar env) id)
(progn (set-cdr! (car env) value)
value)
(update! id (cdr env) value))
(wrong "No such binding" id)))
(define (evaluate e env)
(if (atom? e)
(cond ((eq? e 't) true)
((eq? e 'f) false)
((or (number? e)
(string? e)
(char? e)
(boolean? e)
(vector? e))
e)
((symbol? e) (lookup e env)))
(case (car e)
((quote) (cadr e))
((if) (if (not (eq? (evaluate (cadr e) env) false))
(evaluate (caddr e) env)
(evaluate (cadddr e) env)))
((begin) (eprogn (cdr e)
env))
((set!) (update! (cadr e) env (evaluate (caddr e) env)))
((lambda) (make-function (cadr e) (cddr e) env))
(t (invoke (evaluate (car e) env)
(evlis (cdr e) env))))))
(defvar *depth-var* '#:depth)
(define (eprogn.trace exps env)
(if (pair? exps)
(if (pair? (cdr exps))
(progn (evaluate.trace (car exps) env)
(eprogn.trace (cdr exps)
env))
(evaluate.trace (car exps)
env))
()))
(define (evlis.trace exps env)
(if (pair? exps)
(cons (evaluate.trace (car exps) env)
(evlis.trace (cdr exps) env))
()))
(define (make-function.trace variables body env)
(lambda (values)
(eprogn.trace body
(extend env
variables
values))))
(define (evaluate.trace e env)
(let ((*trace-depth* (1+ *trace-depth*)))
(prog1 (if (atom? e)
(cond ((eq? e 't) true)
((eq? e 'f) false)
((or (number? e)
(string? e)
(char? e)
(boolean? e)
(vector? e))
e)
((symbol? e) (lookup e env)))
(progn
(format *trace-output*
"~&~v,2@t=> (~{~s~^ ~})~%"
(* 2 *trace-depth*)
e)
(let ((result (case (car e)
((quote) (cadr e))
((if) (if (not (eq? (evaluate.trace (cadr e) env) false))
(evaluate.trace (caddr e) env)
(evaluate.trace (cadddr e) env)))
((begin) (eprogn.trace (cdr e)
env))
((set!) (update! (cadr e) env (evaluate.trace (caddr e) env)))
((lambda) (make-function.trace (cadr e) (cddr e) env))
(t (invoke (evaluate.trace (car e) env)
(evlis.trace (cdr e) env))))))
(format *trace-output* "~&~v,2@t<= ~s~%" (* 2 *trace-depth*) result)
result))))))
(defparameter def.extend
(make-function '(env variables values)
'((if (pair? variables)
(if (pair? values)
(cons (cons (car variables) (car values))
(extend env (cdr variables) (cdr values)))
(wrong "Too less values"))
(if (null? variables)
(if (null? values)
env
(wrong "Too much values"))
(if (symbol? variables)
(cons (cons variables values) env)
nil))))
env.global))
(defun scheme-atom? (it)
(if (atom it)
true
false))
(defun scheme-not (it)
(if (eq it true) false true))
(defun scheme-eq? (a b)
(if (eq a b)
true
false))
(defun display (it)
(format *trace-output* "~&~v,2@t ===> ~s~%" (* 2 *trace-depth*) it)
it)
(define (chapter1-scheme)
(definitial apply
(lambda (values)
(apply (car values) (cdr values))))
(definitial t true)
(definitial f false)
(definitial nil '())
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
(definitial evaluate)
(definitial evlis)
(definitial eprogn)
(definitial lookup)
(definitial wrong)
(definitial update!)
(definitial make-function)
(definitial invoke)
(definitial foldl
(make-function '(fn init list)
'((if (null? list)
init
(fn (foldl fn init (cdr list))
(car list))))
env.global))
(definitial extend def.extend)
(definitial env.global env.global)
(defprimitive atom? scheme-atom? 1)
(defprimitive-bool number? number? 1)
(defprimitive-bool vector? vector? 1)
(defprimitive-bool char? char? 1)
(defprimitive-bool boolean? boolean? 1)
(defprimitive-bool string? string? 1)
(defprimitive-bool symbol? symbol? 1)
(defprimitive-bool pair? pair? 1)
(defprimitive-bool function? functionp 1)
(defprimitive-bool null? null? 1)
(defprimitive not scheme-not 1)
(defprimitive cons cons 2)
(defprimitive car car 1)
(defprimitive cdr cdr 1)
(defprimitive caar caar 1)
(defprimitive cadr cadr 1)
(defprimitive cdar cdar 1)
(defprimitive cddr cddr 1)
(defprimitive #1=caaar #1# 1)
(defprimitive #2=caadr #2# 1)
(defprimitive #3=cadar #3# 1)
(defprimitive #4=caddr #4# 1)
(defprimitive #5=cdaar #5# 1)
(defprimitive #6=cdadr #6# 1)
(defprimitive #7=cddar #7# 1)
(defprimitive #8=cdddr #8# 1)
(defprimitive #9=caaaar #9# 1)
(defprimitive #10=caaadr #10# 1)
(defprimitive #11=caadar #11# 1)
(defprimitive #12=caaddr #12# 1)
(defprimitive #13=cadaar #13# 1)
(defprimitive #14=cadadr #14# 1)
(defprimitive #15=caddar #15# 1)
(defprimitive #16=cadddr #16# 1)
(defprimitive #17=cdaaar #17# 1)
(defprimitive #18=cdaadr #18# 1)
(defprimitive #19=cdadar #19# 1)
(defprimitive #20=cdaddr #20# 1)
(defprimitive #21=cddaar #21# 1)
(defprimitive #22=cddadr #22# 1)
(defprimitive #23=cdddar #23# 1)
(defprimitive #24=cddddr #24# 1)
(defprimitive set-cdr! rplacd 2)
(defprimitive + + 2)
(defprimitive * * 2)
(defprimitive-bool = = 2)
(defprimitive eq? scheme-eq? 2)
(defprimitive < < 2)
(defprimitive eql eql 2)
(defprimitive display display 1)
(definitial list
(make-function 'v
'((if (null? v)
()
(cons (car v)
(list (cdr v)))))
env.global))
(setf (cdr (assoc 'invoke env.global))
(make-function '(fn args)
'((if (function? fn)
(apply fn args)
(wrong "Not a function" fn)))
env.global)
(cdr (assoc 'make-function env.global))
(make-function '(variables body env)
'((lambda (values)
(eprogn body
(extend env variables values))))
env.global)
(cdr (assoc 'update! env.global))
(make-function '(id env value)
'((if (pair? env)
(if (eq? (caar env) id)
(begin (set-cdr! (car env) value)
value)
(update! id (cdr env) value))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'wrong env.global))
(make-function '(a b)
'((display (cons a b)))
env.global)
(cdr (assoc 'lookup env.global))
(make-function '(id env)
'((if (pair? env)
(if (eq? (caar env) id)
(cdar env)
(lookup id (cdr env)))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'evaluate env.global))
(make-function '(e env)
'((if (atom? e)
(if (eq? e 't)
t
(if (eq? e 'f)
f
(if (if (number? e) t
(if (string? e) t
(if (char? e) t
(if (boolean? e) t
(vector? e)))))
e
(if (symbol? e)
(lookup e env)
nil))))
((lambda (case-var)
(if (eq? case-var 'quote)
(begin nil (cadr e))
(if (eq? case-var 'if)
(if (not (eq? (evaluate (cadr e) env) f))
(evaluate (caddr e) env)
(evaluate (cadddr e) env))
(if (eq? case-var 'begin)
(eprogn (cdr e) env)
(if (eq? case-var 'set!)
(update! (cadr e) env (evaluate (caddr e) env))
(if (eq? case-var 'lambda)
(make-function (cadr e) (cddr e) env)
(invoke (evaluate (car e) env)
(evlis (cdr e) env))))))))
(car e))))
env.global)
(cdr (assoc 'evlis env.global))
(make-function '(exps env)
'((if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
()))
env.global)
(cdr (assoc 'eprogn env.global))
(make-function '(exps env)
'((if (pair? exps)
(if (pair? (cdr exps))
(begin (evaluate (car exps) env)
(eprogn (cdr exps)
env))
(evaluate (car exps)
env))
()))
env.global))
(labels ((toplevel ()
(fresh-line)
(princ "> ")
(princ (evaluate (let ((it (read)))
(case it
(:quit (return-from toplevel))
(t it)))
env.global))
(terpri)
(toplevel)))
(toplevel)))
(define (chapter1-scheme.trace)
(definitial apply
(lambda (values)
(apply (car values) (cdr values))))
(definitial t true)
(definitial f false)
(definitial nil '())
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
(definitial evaluate)
(definitial evlis)
(definitial eprogn)
(definitial lookup)
(definitial wrong)
(definitial update!)
(definitial make-function)
(definitial invoke)
(definitial foldl
(make-function '(fn init list)
'((if (null? list)
init
(fn (foldl fn init (cdr list))
(car list))))
env.global))
(definitial extend def.extend)
(definitial env.global env.global)
(defprimitive atom? scheme-atom? 1)
(defprimitive-bool number? number? 1)
(defprimitive-bool vector? vector? 1)
(defprimitive-bool char? char? 1)
(defprimitive-bool boolean? boolean? 1)
(defprimitive-bool string? string? 1)
(defprimitive-bool symbol? symbol? 1)
(defprimitive-bool pair? pair? 1)
(defprimitive-bool function? functionp 1)
(defprimitive-bool null? null? 1)
(defprimitive not scheme-not 1)
(defprimitive cons cons 2)
(defprimitive car car 1)
(defprimitive cdr cdr 1)
(defprimitive caar caar 1)
(defprimitive cadr cadr 1)
(defprimitive cdar cdar 1)
(defprimitive cddr cddr 1)
(defprimitive #1=caaar #1# 1)
(defprimitive #2=caadr #2# 1)
(defprimitive #3=cadar #3# 1)
(defprimitive #4=caddr #4# 1)
(defprimitive #5=cdaar #5# 1)
(defprimitive #6=cdadr #6# 1)
(defprimitive #7=cddar #7# 1)
(defprimitive #8=cdddr #8# 1)
(defprimitive #9=caaaar #9# 1)
(defprimitive #10=caaadr #10# 1)
(defprimitive #11=caadar #11# 1)
(defprimitive #12=caaddr #12# 1)
(defprimitive #13=cadaar #13# 1)
(defprimitive #14=cadadr #14# 1)
(defprimitive #15=caddar #15# 1)
(defprimitive #16=cadddr #16# 1)
(defprimitive #17=cdaaar #17# 1)
(defprimitive #18=cdaadr #18# 1)
(defprimitive #19=cdadar #19# 1)
(defprimitive #20=cdaddr #20# 1)
(defprimitive #21=cddaar #21# 1)
(defprimitive #22=cddadr #22# 1)
(defprimitive #23=cdddar #23# 1)
(defprimitive #24=cddddr #24# 1)
(defprimitive set-cdr! rplacd 2)
(defprimitive + + 2)
(defprimitive * * 2)
(defprimitive-bool = = 2)
(defprimitive eq? scheme-eq? 2)
(defprimitive < < 2)
(defprimitive eql eql 2)
(defprimitive display display 1)
(definitial list
(make-function 'v
'((if (null? v)
()
(cons (car v)
(list (cdr v)))))
env.global))
(setf (cdr (assoc 'invoke env.global))
(make-function '(fn args)
'((if (function? fn)
(apply fn args)
(wrong "Not a function" fn)))
env.global)
(cdr (assoc 'make-function env.global))
(make-function '(variables body env)
'((lambda (values)
(eprogn body
(extend env variables values))))
env.global)
(cdr (assoc 'update! env.global))
(make-function '(id env value)
'((if (pair? env)
(if (eq? (caar env) id)
(begin (set-cdr! (car env) value)
value)
(update! id (cdr env) value))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'wrong env.global))
(make-function '(a b)
'((display (cons a b)))
env.global)
(cdr (assoc 'lookup env.global))
(make-function '(id env)
'((if (pair? env)
(if (eq? (caar env) id)
(cdar env)
(lookup id (cdr env)))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'evaluate env.global))
(make-function '(e env)
'((if (atom? e)
(if (eq? e 't)
t
(if (eq? e 'f)
f
(if (if (number? e) t
(if (string? e) t
(if (char? e) t
(if (boolean? e) t
(vector? e)))))
e
(if (symbol? e)
(lookup e env)
nil))))
((lambda (case-var)
(if (eq? case-var 'quote)
(begin nil (cadr e))
(if (eq? case-var 'if)
(if (not (eq? (evaluate (cadr e) env) f))
(evaluate (caddr e) env)
(evaluate (cadddr e) env))
(if (eq? case-var 'begin)
(eprogn (cdr e) env)
(if (eq? case-var 'set!)
(update! (cadr e) env (evaluate (caddr e) env))
(if (eq? case-var 'lambda)
(make-function (cadr e) (cddr e) env)
(invoke (evaluate (car e) env)
(evlis (cdr e) env))))))))
(car e))))
env.global)
(cdr (assoc 'evlis env.global))
(make-function '(exps env)
'((if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
()))
env.global)
(cdr (assoc 'eprogn env.global))
(make-function '(exps env)
'((if (pair? exps)
(if (pair? (cdr exps))
(begin (evaluate (car exps) env)
(eprogn (cdr exps)
env))
(evaluate (car exps)
env))
()))
env.global))
(labels ((toplevel ()
(fresh-line)
(princ (evaluate.trace (let ((it (read)))
(case it
(:quit (return-from toplevel))
(t it)))
env.global))
(terpri)
(toplevel)))
(toplevel)))
(define (d.make-function variables body env)
(declare (ignore env))
(lambda (values current.env)
(d.eprogn body
(extend current.env
variables
values))))
(define (d.invoke fn args env)
(if (functionp fn)
(funcall fn args env)
(wrong "Not a function" fn)))
(define (d.eprogn exps env)
(if (pair? exps)
(if (pair? (cdr exps))
(progn (d.evaluate (car exps) env)
(d.eprogn (cdr exps)
env))
(d.evaluate (car exps)
env))
()))
(define (d.evlis exps env)
(if (pair? exps)
(cons (d.evaluate (car exps) env)
(d.evlis (cdr exps) env))
()))
(define (d.evaluate e env)
(if (atom? e)
(cond ((or (number? e)
(string? e)
(char? e)
(boolean? e)
(vector? e))
e)
((symbol? e) (lookup e env)))
(case (car e)
((quote) (cadr e))
((if) (if (not (eq? (d.evaluate (cadr e) env) false))
(d.evaluate (caddr e) env)
(d.evaluate (cadddr e) env)))
((begin) (d.eprogn (cdr e)
env))
((set!) (update! (cadr e) env (d.evaluate (caddr e) env)))
((lambda) (d.make-function (cadr e) (cddr e) nil))
(t (d.invoke (d.evaluate (car e) env)
(d.evlis (cdr e) env)
env)))))
(define (d.chapter1-scheme)
(definitial apply
(lambda (values)
(apply (car values) (cdr values))))
(definitial t true)
(definitial f false)
(definitial nil '())
(definitial foo)
(definitial bar)
(definitial fib)
(definitial fact)
(definitial evaluate)
(definitial evlis)
(definitial eprogn)
(definitial lookup)
(definitial wrong)
(definitial update!)
(definitial make-function)
(definitial invoke)
(definitial foldl
(make-function '(fn init list)
'((if (null? list)
init
(fn (foldl fn init (cdr list))
(car list))))
env.global))
(definitial extend def.extend)
(definitial env.global env.global)
(defprimitive atom? scheme-atom? 1)
(defprimitive-bool number? number? 1)
(defprimitive-bool vector? vector? 1)
(defprimitive-bool char? char? 1)
(defprimitive-bool boolean? boolean? 1)
(defprimitive-bool string? string? 1)
(defprimitive-bool symbol? symbol? 1)
(defprimitive-bool pair? pair? 1)
(defprimitive-bool function? functionp 1)
(defprimitive-bool null? null? 1)
(defprimitive not scheme-not 1)
(defprimitive cons cons 2)
(defprimitive car car 1)
(defprimitive cdr cdr 1)
(defprimitive caar caar 1)
(defprimitive cadr cadr 1)
(defprimitive cdar cdar 1)
(defprimitive cddr cddr 1)
(defprimitive #1=caaar #1# 1)
(defprimitive #2=caadr #2# 1)
(defprimitive #3=cadar #3# 1)
(defprimitive #4=caddr #4# 1)
(defprimitive #5=cdaar #5# 1)
(defprimitive #6=cdadr #6# 1)
(defprimitive #7=cddar #7# 1)
(defprimitive #8=cdddr #8# 1)
(defprimitive #9=caaaar #9# 1)
(defprimitive #10=caaadr #10# 1)
(defprimitive #11=caadar #11# 1)
(defprimitive #12=caaddr #12# 1)
(defprimitive #13=cadaar #13# 1)
(defprimitive #14=cadadr #14# 1)
(defprimitive #15=caddar #15# 1)
(defprimitive #16=cadddr #16# 1)
(defprimitive #17=cdaaar #17# 1)
(defprimitive #18=cdaadr #18# 1)
(defprimitive #19=cdadar #19# 1)
(defprimitive #20=cdaddr #20# 1)
(defprimitive #21=cddaar #21# 1)
(defprimitive #22=cddadr #22# 1)
(defprimitive #23=cdddar #23# 1)
(defprimitive #24=cddddr #24# 1)
(defprimitive set-cdr! rplacd 2)
(defprimitive + + 2)
(defprimitive * * 2)
(defprimitive = = 2)
(defprimitive eq? scheme-eq? 2)
(defprimitive < < 2)
(defprimitive eql eql 2)
(defprimitive display display 1)
(definitial list
(d.make-function 'v
'((if (null? v)
()
(cons (car v)
(list (cdr v)))))
env.global))
(setf (cdr (assoc 'invoke env.global))
(d.make-function '(fn args)
'((if (function? fn)
(apply fn args)
(wrong "Not a function" fn)))
env.global)
(cdr (assoc 'make-function env.global))
(d.make-function '(variables body env)
'((lambda (values)
(eprogn body
(extend env variables values))))
env.global)
(cdr (assoc 'update! env.global))
(d.make-function '(id env value)
'((if (pair? env)
(if (eq? (caar env) id)
(begin (set-cdr! (car env) value)
value)
(update! id (cdr env) value))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'wrong env.global))
(d.make-function '(a b)
'((display (cons a b)))
env.global)
(cdr (assoc 'lookup env.global))
(d.make-function '(id env)
'((if (pair? env)
(if (eq? (caar env) id)
(cdar env)
(lookup id (cdr env)))
(wrong "No such binding" id)))
env.global)
(cdr (assoc 'evaluate env.global))
(d.make-function '(e env)
'((if (atom? e)
(if (eq? e 't)
t
(if (eq? e 'f)
f
(if (if (number? e) t
(if (string? e) t
(if (char? e) t
(if (boolean? e) t
(vector? e)))))
e
(if (symbol? e)
(lookup e env)
nil))))
((lambda (case-var)
(if (eq? case-var 'quote)
(begin nil (cadr e))
(if (eq? case-var 'if)
(if (not (eq? (evaluate (cadr e) env) f))
(evaluate (caddr e) env)
(evaluate (cadddr e) env))
(if (eq? case-var 'begin)
(eprogn (cdr e) env)
(if (eq? case-var 'set!)
(update! (cadr e) env (evaluate (caddr e) env))
(if (eq? case-var 'lambda)
(d.make-function (cadr e) (cddr e) env)
(invoke (evaluate (car e) env)
(evlis (cdr e) env))))))))
(car e))))
env.global)
(cdr (assoc 'evlis env.global))
(d.make-function '(exps env)
'((if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
()))
env.global)
(cdr (assoc 'eprogn env.global))
(d.make-function '(exps env)
'((if (pair? exps)
(if (pair? (cdr exps))
(begin (evaluate (car exps) env)
(eprogn (cdr exps)
env))
(evaluate (car exps)
env))
()))
env.global))
(labels ((toplevel ()
(fresh-line)
(princ (d.evaluate (let ((it (read)))
(case it
(:quit (return-from toplevel))
(t it)))
env.global))
(terpri)
(toplevel)))
(toplevel)))