(defpackage :fwoar.lisp-sandbox.2
(:use :cl )
(:export ))
(in-package :fwoar.lisp-sandbox.2)
(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))
(define (->cl bool)
(if (eq bool true) t nil))
(defvar empty-begin 813)
(define (wrong &rest args)
(error "~{~a~^ ~}" args))
(defvar env.init ())
(defvar env.global (cons nil env.init))
(defvar fenv.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 definitial-function (name &optional (value nil value-p))
(if value-p
`(progn (adjoinf (cdr fenv.global)
(cons ',name ,value)
:test (key-eql #'car))
',name)
`(progn (adjoinf (cdr fenv.global)
(cons ',name '#:uninit)
:test (key-eql #'car))
',name)))
(defmacro defprimitive (name value arity)
`(definitial-function ,name
(lambda (values &optional env)
(declare (ignore env))
(if (= ,arity (length values))
(apply ',value values)
(wrong "incorrect arity" ',name ,arity values)))))
(defmacro defprimitive-bool (name value arity)
`(definitial-function ,name
(lambda (values &optional env)
(declare (ignore 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 (f.make-function variables body env fenv)
(lambda (values)
(f.eprogn body
(extend env
variables
values)
fenv)))
(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 (f.evaluate e env fenv)
(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))
((wrong "Cannot evaluate" e)))
(case (car e)
((quote) (cadr e))
((if) (if (->cl (f.evaluate (cadr e)
env fenv))
(f.evaluate (caddr e)
env fenv)
(f.evaluate (cadddr e)
env fenv)))
((begin) (f.eprogn (cdr e)
env
fenv))
((set!) (update! (cadr e)
env
(f.evaluate (caddr e)
env
fenv)))
((function) (cond ((symbol? (cadr e))
(f.lookup (cadr e)
fenv))
((and (pair? (cadr e))
(eq? (cadr e)
'lambda))
(f.make-function (cadr (cadr e))
(cddr (cadr e))
env fenv))
((wrong "Incorrect function" (cadr e)))))
((lambda) (make-function (cadr e)
(cddr e)
env))
((flet)
(f.eprogn (cddr e)
env
(extend fenv
(mapcar 'car (cadr e))
(mapcar (lambda (def)
(f.make-function (cadr def)
(cddr def)
env fenv))
(cadr e)))))
((labels)
(let ((new-fenv (extend fenv
(mapcar 'car
(cadr e))
(mapcar (lambda (def)
'void)
(cadr e)))))
(mapc (lambda (def)
(update! (car def)
new-fenv
(f.make-function (cadr def)
(cddr def)
env new-fenv)))
(cadr e))
(f.eprogn (cddr e)
env new-fenv)))
(t (f.evaluate-application (car e)
(f.evlis (cdr e)
env fenv)
env fenv)))))
(define (f.eprogn exps env fenv)
(if (pair? exps)
(if (pair? (cdr exps))
(progn (f.evaluate (car exps) env fenv)
(eprogn (cdr exps)
env))
(f.evaluate (car exps)
env fenv))
empty-begin))
(define (f.evlis exps env fenv)
(if (pair? exps)
(cons (f.evaluate (car exps) env fenv)
(f.evlis (cdr exps) env fenv))
()))
(define (f.evaluate-application fn args env fenv)
(cond ((symbol? fn)
(funcall (f.lookup fn fenv) args))
((and (pair? fn)
(eq? (car fn)
'ambda))
(f.eprogn (cddr fn)
(extend env
(cadr fn)
args)
fenv))
((wrong "Incorrect functional term" fn))))
(define (f.lookup id fenv)
(if (pair? fenv)
(if (eq? (caar fenv)
id)
(cdar fenv)
(f.lookup id
(cdr fenv)))
(lambda (values)
(declare (ignore values))
(wrong "No such functional binding" id))))
(defparameter def.extend
(f.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
fenv.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 (chapter2-scheme)
(definitial apply
(lambda (values)
(apply (car values) (cdr values))))
(definitial t true)
(definitial f false)
(definitial nil '())
(definitial foo)
(definitial bar)
(definitial-function fib)
(definitial-function fact)
(definitial-function evaluate)
(definitial-function evlis)
(definitial-function eprogn)
(definitial-function lookup)
(definitial-function wrong)
(definitial-function update!)
(definitial-function make-function)
(definitial-function invoke)
(definitial-function foldl
(f.make-function '(fn init list)
'((if (null? list)
init
(fn (foldl fn init (cdr list))
(car list))))
env.global
fenv.global))
(definitial-function 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
(f.make-function 'v
'((if (null? v)
()
(cons (car v)
(list (cdr v)))))
env.global
fenv.global))
(setf (cdr (assoc 'invoke fenv.global))
(f.make-function '(fn args)
'((if (function? fn)
(apply fn args)
(wrong "Not a function" fn)))
env.global
fenv.global)
(cdr (assoc 'make-function fenv.global))
(f.make-function '(variables body env)
'((lambda (values)
(eprogn body
(extend env variables values))))
env.global
fenv.global)
(cdr (assoc 'update! fenv.global))
(f.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
fenv.global)
(cdr (assoc 'wrong fenv.global))
(f.make-function '(a b)
'((display (cons a b)))
env.global
fenv.global)
(cdr (assoc 'lookup fenv.global))
(f.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
fenv.global)
(cdr (assoc 'evaluate fenv.global))
(f.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)
(f.make-function (cadr e) (cddr e) env)
(invoke (evaluate (car e) env)
(evlis (cdr e) env))))))))
(car e))))
env.global
fenv.global)
(cdr (assoc 'evlis fenv.global))
(f.make-function '(exps env)
'((if (pair? exps)
(cons (evaluate (car exps) env)
(evlis (cdr exps) env))
()))
env.global
fenv.global)
(cdr (assoc 'eprogn fenv.global))
(f.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
fenv.global))
(labels ((toplevel ()
(fresh-line)
(princ "> ")
(with-simple-restart (continue "continue scheme repl")
(princ (f.evaluate (let ((it (read)))
(case it
(:quit (return-from toplevel))
(t it)))
env.global
fenv.global)))
(terpri)
(toplevel)))
(toplevel)))