Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

init

  • Loading branch information...
commit 2139060eed1ce74b65bf761392fd15b58e3232af 0 parents
@kmcallister authored
Showing with 238 additions and 0 deletions.
  1. +143 −0 prelude.qop
  2. +95 −0 qoppa.scm
143 prelude.qop
@@ -0,0 +1,143 @@
+((vau (name-of-define null) env
+ (set-car! env
+ (cons
+ (cons
+ name-of-define
+ (cons
+ (vau (name exp) defn-env
+ (set-car! defn-env
+ (cons
+ (cons name (cons (eval defn-env exp) null))
+ (car defn-env))))
+ null))
+ (car env))))
+ define ())
+
+(define if (vau (b t f) env
+ (eval env (bool (eval env b) t f))))
+
+(define quote (vau (x) _ x))
+
+(define list (vau xs env
+ (if (null? xs)
+ '()
+ (cons
+ (eval env (car xs))
+ (eval env (cons list (cdr xs)))))))
+
+(define wrap (vau (operative) oper-env
+ (vau args args-env
+ (operate args-env
+ (eval oper-env operative)
+ (operate args-env list args)))))
+
+(define lambda (vau (params body) static-env
+ (wrap
+ (eval static-env
+ (list vau params '_ body)))))
+
+(define fact (lambda (n)
+ (if (<= n 1)
+ 1
+ (* n (fact (- n 1))))))
+
+(define last (lambda (xs)
+ (if (null? (cdr xs))
+ (car xs)
+ (last (cdr xs)))))
+
+(define begin (lambda xs (last xs)))
+
+(define set! (vau (name exp) env
+ (set-cdr!
+ (lookup name env)
+ (list (eval env exp)))))
+
+(set! lambda
+ ((lambda (base-lambda)
+ (vau (param . body) env
+ (eval env (list base-lambda param (cons begin body)))))
+ lambda))
+
+(set! define
+ ((lambda (base-define)
+ (vau (param . body) env
+ (if (pair? param)
+ (eval env
+ (list base-define (car param)
+ (cons lambda (cons (cdr param) body))))
+ (eval env (cons base-define (cons param body))))))
+ define))
+
+(define (compose f g)
+ (lambda (x) (f (g x))))
+
+(define caar (compose car car))
+(define cadr (compose car cdr))
+(define caddr (compose cadr cdr))
+
+(define (fib n)
+ (display n)
+ (display "\n")
+ (if (<= n 1)
+ n
+ (+ (fib (- n 1)) (fib (- n 2)))))
+
+(define (map f xs)
+ (if (null? xs)
+ '()
+ (cons (f (car xs)) (map f (cdr xs)))))
+
+(define let (vau (binds . body) env
+ (eval env
+ (cons
+ (cons lambda (cons (map car binds) body))
+ (map cadr binds)))))
+
+(define (to-bool x)
+ (if x #t #f))
+
+(define (not x)
+ (if x #f #t))
+
+(define (and-or ident) (vau args env
+ (if (null? args)
+ ident
+ (if (eq? ident (to-bool (eval env (car args))))
+ (eval env (cons (list and-or ident) (cdr args)))
+ (not ident)))))
+
+(define or (and-or #f))
+(define and (and-or #t))
+
+(define cond (vau alts env
+ (if (null? alts)
+ #f
+ (let (( ((test body) . rest) alts ))
+ (if (or (eq? test 'else)
+ (eval env test))
+ (eval env body)
+ (eval env (cons cond rest)))))))
+
+(define (assq key alist) (cond
+ ((null? alist)
+ #f)
+ ((eq? key (caar alist))
+ (car alist))
+ (else
+ (assq key (cdr alist)))))
+
+(define (foldr f z xs)
+ (if (null? xs)
+ z
+ (f (car xs) (foldr f z (cdr xs)))))
+
+(define (append a b)
+ (foldr cons b a))
+
+(define apply (wrap (vau (operative args) env
+ (eval env (cons
+ operative
+ (map (lambda (x) (list quote x)) args))))))
+
+; vim: ft=scheme
95 qoppa.scm
@@ -0,0 +1,95 @@
+(define (bind param val) (cond
+ ((and (null? param) (null? val))
+ '())
+ ((eq? param '_)
+ '())
+ ((symbol? param)
+ (list (list param val)))
+ ((and (pair? param) (pair? val))
+ (append
+ (bind (car param) (car val))
+ (bind (cdr param) (cdr val))))
+ (else
+ (error "can't bind" param val))))
+
+(define (m-lookup name env)
+ (if (null? env)
+ (error "could not find" name)
+ (let ((binding (assq name (car env))))
+ (if binding
+ binding
+ (m-lookup name (cdr env))))))
+
+(define (m-eval env exp) (cond
+ ((symbol? exp)
+ (cadr (m-lookup exp env)))
+ ((pair? exp)
+ (m-operate env (m-eval env (car exp)) (cdr exp)))
+ (else
+ exp)))
+
+(define (m-operate env operative operands)
+ (operative env operands))
+
+(define (make-operative static-env vau-operands)
+ (let ((params (car vau-operands))
+ (env-param (cadr vau-operands))
+ (body (caddr vau-operands)))
+
+ (lambda (dynamic-env operands)
+ (m-eval
+ (cons
+ (bind
+ (cons env-param params)
+ (cons dynamic-env operands))
+ static-env)
+ body))))
+
+(define (make-global-frame)
+ (define (wrap-prim pair)
+ (list (car pair) (lambda (env operands)
+ (apply (cadr pair)
+ (map (lambda (exp) (m-eval env exp)) operands)))))
+ (cons
+ (list 'vau make-operative)
+ (map wrap-prim (list
+ (list 'lookup m-lookup)
+ (list 'eval m-eval)
+ (list 'operate m-operate)
+ (list 'bool (lambda (b t f) (if b t f)))
+ (list 'eq? eq?)
+ (list 'null? null?)
+ (list 'symbol? symbol?)
+ (list 'pair? pair?)
+ (list 'cons cons)
+ (list 'car car)
+ (list 'cdr cdr)
+ (list 'set-car! set-car!)
+ (list 'set-cdr! set-cdr!)
+ (list 'error error)
+ (list 'display display)
+ (list '+ +)
+ (list '* *)
+ (list '- -)
+ (list '/ /)
+ (list '<= <=)
+ (list '= =)
+ (list 'open-input-file open-input-file)
+ (list 'read read)
+ (list 'eof-object? eof-object?)))))
+
+(define global-env (list (make-global-frame)))
+
+(define (execute-file filename)
+ (let ((stream (open-input-file filename)))
+ (define (loop)
+ (let ((exp (read stream)))
+ (if (eof-object? exp)
+ 'done
+ (begin
+ (display exp) (display "\n")
+ (m-eval global-env exp)
+ (loop)))))
+ (loop)))
+
+(execute-file "prelude.qop")
Please sign in to comment.
Something went wrong with that request. Please try again.