adding #b, #o, #d, #x numeric literals
accepting r6rs IEEE literals +-nan.0 and +-inf.0 printing distinguished -0.0, indicating float with .0f instead of #float, double with .0 instead of #double more renaming (? on predicates, ! on mutating operators) changing T to #t :( all those #s are so ugly
This commit is contained in:
JeffBezanson
parent
a55b46e9a6
commit
17d81eb4e6
|
|
@ -10,23 +10,23 @@
|
|||
(cons item lst)))
|
||||
|
||||
(define (index-of item lst start)
|
||||
(cond ((null lst) #f)
|
||||
(cond ((null? lst) #f)
|
||||
((eq item (car lst)) start)
|
||||
(T (index-of item (cdr lst) (+ start 1)))))
|
||||
(#t (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (each f l)
|
||||
(if (null l) l
|
||||
(if (null? l) l
|
||||
(begin (f (car l))
|
||||
(each f (cdr l)))))
|
||||
|
||||
(define (maptree-pre f tr)
|
||||
(let ((new-t (f tr)))
|
||||
(if (consp new-t)
|
||||
(if (pair? new-t)
|
||||
(map (lambda (e) (maptree-pre f e)) new-t)
|
||||
new-t)))
|
||||
|
||||
(define (maptree-post f tr)
|
||||
(if (not (consp tr))
|
||||
(if (not (pair? tr))
|
||||
(f tr)
|
||||
(let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
|
||||
(f new-t))))
|
||||
|
|
@ -70,10 +70,10 @@
|
|||
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
|
||||
(define (flatten-left-op op e)
|
||||
(maptree-post (lambda (node)
|
||||
(if (and (consp node)
|
||||
(if (and (pair? node)
|
||||
(eq (car node) op)
|
||||
(consp (cdr node))
|
||||
(consp (cadr node))
|
||||
(pair? (cdr node))
|
||||
(pair? (cadr node))
|
||||
(eq (caadr node) op))
|
||||
(cons op
|
||||
(append (cdadr node) (cddr node)))
|
||||
|
|
@ -85,31 +85,31 @@
|
|||
; name is just there for reference
|
||||
; this assumes lambda is the only remaining naming form
|
||||
(define (lookup-var v env lev)
|
||||
(if (null env) v
|
||||
(if (null? env) v
|
||||
(let ((i (index-of v (car env) 0)))
|
||||
(if i (list 'lexref lev i v)
|
||||
(lookup-var v (cdr env) (+ lev 1))))))
|
||||
(define (lvc- e env)
|
||||
(cond ((symbolp e) (lookup-var e env 0))
|
||||
((consp e)
|
||||
(cond ((symbol? e) (lookup-var e env 0))
|
||||
((pair? e)
|
||||
(if (eq (car e) 'quote)
|
||||
e
|
||||
(let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
|
||||
(newenv (if newvs (cons newvs env) env)))
|
||||
(if newvs
|
||||
(cons 'lambda
|
||||
(cons (cadr e)
|
||||
(map (lambda (se) (lvc- se newenv))
|
||||
(cddr e))))
|
||||
(map (lambda (se) (lvc- se env)) e)))))
|
||||
(T e)))
|
||||
(let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
|
||||
(newenv (if newvs (cons newvs env) env)))
|
||||
(if newvs
|
||||
(cons 'lambda
|
||||
(cons (cadr e)
|
||||
(map (lambda (se) (lvc- se newenv))
|
||||
(cddr e))))
|
||||
(map (lambda (se) (lvc- se env)) e)))))
|
||||
(#t e)))
|
||||
(define (lexical-var-conversion e)
|
||||
(lvc- e ()))
|
||||
|
||||
; convert let to lambda
|
||||
(define (let-expand e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'let))
|
||||
(if (and (pair? n) (eq (car n) 'let))
|
||||
`((lambda ,(map car (cadr n)) ,@(cddr n))
|
||||
,@(map cadr (cadr n)))
|
||||
n))
|
||||
|
|
|
|||
|
|
@ -3,11 +3,11 @@
|
|||
; by Jeff Bezanson
|
||||
|
||||
(define (unique lst)
|
||||
(if (null lst)
|
||||
(if (null? lst)
|
||||
()
|
||||
(cons (car lst)
|
||||
(filter (lambda (x) (not (eq x (car lst))))
|
||||
(unique (cdr lst))))))
|
||||
(cons (car lst)
|
||||
(filter (lambda (x) (not (eq x (car lst))))
|
||||
(unique (cdr lst))))))
|
||||
|
||||
; list of special pattern symbols that cannot be variable names
|
||||
(define metasymbols '(_ ...))
|
||||
|
|
@ -39,18 +39,18 @@
|
|||
; This is NP-complete. Be careful.
|
||||
;
|
||||
(define (match- p expr state)
|
||||
(cond ((symbolp p)
|
||||
(cond ((symbol? p)
|
||||
(cond ((eq p '_) state)
|
||||
(T
|
||||
(#t
|
||||
(let ((capt (assq p state)))
|
||||
(if capt
|
||||
(and (equal expr (cdr capt)) state)
|
||||
(cons (cons p expr) state))))))
|
||||
(cons (cons p expr) state))))))
|
||||
|
||||
((function? p)
|
||||
((procedure? p)
|
||||
(and (p expr) state))
|
||||
|
||||
((consp p)
|
||||
((pair? p)
|
||||
(cond ((eq (car p) '-/) (and (equal (cadr p) expr) state))
|
||||
((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
|
||||
((eq (car p) '--)
|
||||
|
|
@ -58,43 +58,43 @@
|
|||
(cons (cons (cadr p) expr) state)))
|
||||
((eq (car p) '-$) ; greedy alternation for toplevel pattern
|
||||
(match-alt (cdr p) () (list expr) state #f 1))
|
||||
(T
|
||||
(and (consp expr)
|
||||
(#t
|
||||
(and (pair? expr)
|
||||
(equal (car p) (car expr))
|
||||
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
|
||||
|
||||
(T
|
||||
(#t
|
||||
(and (equal p expr) state))))
|
||||
|
||||
; match an alternation
|
||||
(define (match-alt alt prest expr state var L)
|
||||
(if (null alt) #f ; no alternatives left
|
||||
(let ((subma (match- (car alt) (car expr) state)))
|
||||
(or (and subma
|
||||
(match-seq prest (cdr expr)
|
||||
(if var
|
||||
(cons (cons var (car expr))
|
||||
subma)
|
||||
subma)
|
||||
(- L 1)))
|
||||
(match-alt (cdr alt) prest expr state var L)))))
|
||||
(if (null? alt) #f ; no alternatives left
|
||||
(let ((subma (match- (car alt) (car expr) state)))
|
||||
(or (and subma
|
||||
(match-seq prest (cdr expr)
|
||||
(if var
|
||||
(cons (cons var (car expr))
|
||||
subma)
|
||||
subma)
|
||||
(- L 1)))
|
||||
(match-alt (cdr alt) prest expr state var L)))))
|
||||
|
||||
; match generalized kleene star (try consuming min to max)
|
||||
(define (match-star- p prest expr state var min max L sofar)
|
||||
(cond ; case 0: impossible to match
|
||||
((> min max) #f)
|
||||
; case 1: only allowed to match 0 subexpressions
|
||||
; case 1: only allowed to match 0 subexpressions
|
||||
((= max 0) (match-seq prest expr
|
||||
(if var (cons (cons var (reverse sofar)) state)
|
||||
state)
|
||||
state)
|
||||
L))
|
||||
; case 2: must match at least 1
|
||||
; case 2: must match at least 1
|
||||
((> min 0)
|
||||
(and (match- p (car expr) state)
|
||||
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
|
||||
(cons (car expr) sofar))))
|
||||
; otherwise, must match either 0 or between 1 and max subexpressions
|
||||
(T
|
||||
; otherwise, must match either 0 or between 1 and max subexpressions
|
||||
(#t
|
||||
(or (match-star- p prest expr state var 0 0 L sofar)
|
||||
(match-star- p prest expr state var 1 max L sofar)))))
|
||||
(define (match-star p prest expr state var min max L)
|
||||
|
|
@ -103,16 +103,16 @@
|
|||
; match sequences of expressions
|
||||
(define (match-seq p expr state L)
|
||||
(cond ((not state) #f)
|
||||
((null p) (if (null expr) state #f))
|
||||
(T
|
||||
((null? p) (if (null? expr) state #f))
|
||||
(#t
|
||||
(let ((subp (car p))
|
||||
(var #f))
|
||||
(if (and (consp subp)
|
||||
(if (and (pair? subp)
|
||||
(eq (car subp) '--))
|
||||
(begin (set! var (cadr subp))
|
||||
(set! subp (caddr subp)))
|
||||
#f)
|
||||
(let ((head (if (consp subp) (car subp) ())))
|
||||
#f)
|
||||
(let ((head (if (pair? subp) (car subp) ())))
|
||||
(cond ((eq subp '...)
|
||||
(match-star '_ (cdr p) expr state var 0 L L))
|
||||
((eq head '-*)
|
||||
|
|
@ -123,8 +123,8 @@
|
|||
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
|
||||
((eq head '-$)
|
||||
(match-alt (cdr subp) (cdr p) expr state var L))
|
||||
(T
|
||||
(and (consp expr)
|
||||
(#t
|
||||
(and (pair? expr)
|
||||
(match-seq (cdr p) (cdr expr)
|
||||
(match- (car p) (car expr) state)
|
||||
(- L 1))))))))))
|
||||
|
|
@ -133,32 +133,32 @@
|
|||
|
||||
; given a pattern p, return the list of capturing variables it uses
|
||||
(define (patargs- p)
|
||||
(cond ((and (symbolp p)
|
||||
(cond ((and (symbol? p)
|
||||
(not (member p metasymbols)))
|
||||
(list p))
|
||||
|
||||
((consp p)
|
||||
((pair? p)
|
||||
(if (eq (car p) '-/)
|
||||
()
|
||||
(unique (apply append (map patargs- (cdr p))))))
|
||||
(unique (apply append (map patargs- (cdr p))))))
|
||||
|
||||
(T ())))
|
||||
(#t ())))
|
||||
(define (patargs p)
|
||||
(cons '__ (patargs- p)))
|
||||
|
||||
; try to transform expr using a pattern-lambda from plist
|
||||
; returns the new expression, or expr if no matches
|
||||
(define (apply-patterns plist expr)
|
||||
(if (null plist) expr
|
||||
(if (function? plist)
|
||||
(let ((enew (plist expr)))
|
||||
(if (not enew)
|
||||
expr
|
||||
enew))
|
||||
(let ((enew ((car plist) expr)))
|
||||
(if (not enew)
|
||||
(apply-patterns (cdr plist) expr)
|
||||
enew)))))
|
||||
(if (null? plist) expr
|
||||
(if (procedure? plist)
|
||||
(let ((enew (plist expr)))
|
||||
(if (not enew)
|
||||
expr
|
||||
enew))
|
||||
(let ((enew ((car plist) expr)))
|
||||
(if (not enew)
|
||||
(apply-patterns (cdr plist) expr)
|
||||
enew)))))
|
||||
|
||||
; top-down fixed-point macroexpansion. this is a typical algorithm,
|
||||
; but it may leave some structure that matches a pattern unexpanded.
|
||||
|
|
@ -170,13 +170,12 @@
|
|||
; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
|
||||
; TODO: ignore quoted expressions
|
||||
(define (pattern-expand plist expr)
|
||||
(if (not (consp expr))
|
||||
(if (not (pair? expr))
|
||||
expr
|
||||
(let ((enew (apply-patterns plist expr)))
|
||||
(if (eq enew expr)
|
||||
; expr didn't change; move to subexpressions
|
||||
(cons (car expr)
|
||||
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
|
||||
; expr changed; iterate
|
||||
|
||||
(pattern-expand plist enew)))))
|
||||
(let ((enew (apply-patterns plist expr)))
|
||||
(if (eq enew expr)
|
||||
; expr didn't change; move to subexpressions
|
||||
(cons (car expr)
|
||||
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
|
||||
; expr changed; iterate
|
||||
(pattern-expand plist enew)))))
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@
|
|||
; tree inspection utils
|
||||
|
||||
(define (assigned-var e)
|
||||
(and (consp e)
|
||||
(and (pair? e)
|
||||
(or (eq (car e) '<-) (eq (car e) 'ref=))
|
||||
(symbolp (cadr e))
|
||||
(symbol? (cadr e))
|
||||
(cadr e)))
|
||||
|
||||
(define (func-argnames f)
|
||||
|
|
@ -26,13 +26,13 @@
|
|||
(define (dollarsign-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda ($ lhs name)
|
||||
(let* ((g (if (not (consp lhs)) lhs (r-gensym)))
|
||||
(n (if (symbolp name)
|
||||
(let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
|
||||
(n (if (symbol? name)
|
||||
name ;(symbol->string name)
|
||||
name))
|
||||
(expr `(r-call
|
||||
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
|
||||
(if (not (consp lhs))
|
||||
(if (not (pair? lhs))
|
||||
expr
|
||||
`(r-block (ref= ,g ,lhs) ,expr))))
|
||||
e))
|
||||
|
|
@ -46,9 +46,9 @@
|
|||
(pattern-expand
|
||||
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
|
||||
(<<- (r-call f lhs ...) rhs))
|
||||
(let ((g (if (consp rhs) (r-gensym) rhs))
|
||||
(let ((g (if (pair? rhs) (r-gensym) rhs))
|
||||
(op (car __)))
|
||||
`(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
|
||||
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
|
||||
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
|
||||
,g)))
|
||||
e))
|
||||
|
|
@ -68,10 +68,10 @@
|
|||
; convert r function expressions to lambda
|
||||
(define (normalize-r-functions e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'function))
|
||||
(if (and (pair? n) (eq (car n) 'function))
|
||||
`(lambda ,(func-argnames n)
|
||||
(r-block ,@(gen-default-inits (cadr n))
|
||||
,@(if (and (consp (caddr n))
|
||||
,@(if (and (pair? (caddr n))
|
||||
(eq (car (caddr n)) 'r-block))
|
||||
(cdr (caddr n))
|
||||
(list (caddr n)))))
|
||||
|
|
@ -81,19 +81,19 @@
|
|||
(define (find-assigned-vars n)
|
||||
(let ((vars ()))
|
||||
(maptree-pre (lambda (s)
|
||||
(if (not (consp s)) s
|
||||
(if (not (pair? s)) s
|
||||
(cond ((eq (car s) 'lambda) ())
|
||||
((eq (car s) '<-)
|
||||
(set! vars (list-adjoin (cadr s) vars))
|
||||
(cddr s))
|
||||
(T s))))
|
||||
(#t s))))
|
||||
n)
|
||||
vars))
|
||||
|
||||
; introduce let based on assignment statements
|
||||
(define (letbind-locals e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'lambda))
|
||||
(if (and (pair? n) (eq (car n) 'lambda))
|
||||
(let ((vars (find-assigned-vars (cddr n))))
|
||||
`(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
|
||||
vars)
|
||||
|
|
|
|||
|
|
@ -1,23 +1,17 @@
|
|||
; -*- scheme -*-
|
||||
; uncomment for compatibility with CL
|
||||
;(defun mapp (f l) (mapcar f l))
|
||||
;(defmacro define (name &rest body)
|
||||
; (if (symbolp name)
|
||||
; (list 'setq name (car body))
|
||||
; (list 'defun (car name) (cdr name) (cons 'progn body))))
|
||||
|
||||
; dictionaries ----------------------------------------------------------------
|
||||
(define (dict-new) ())
|
||||
|
||||
(define (dict-extend dl key value)
|
||||
(cond ((null dl) (list (cons key value)))
|
||||
((equal key (caar dl)) (cons (cons key value) (cdr dl)))
|
||||
(T (cons (car dl) (dict-extend (cdr dl) key value)))))
|
||||
(cond ((null? dl) (list (cons key value)))
|
||||
((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
|
||||
(else (cons (car dl) (dict-extend (cdr dl) key value)))))
|
||||
|
||||
(define (dict-lookup dl key)
|
||||
(cond ((null dl) ())
|
||||
((equal key (caar dl)) (cdar dl))
|
||||
(T (dict-lookup (cdr dl) key))))
|
||||
(cond ((null? dl) ())
|
||||
((equal? key (caar dl)) (cdar dl))
|
||||
(else (dict-lookup (cdr dl) key))))
|
||||
|
||||
(define (dict-keys dl) (map car dl))
|
||||
|
||||
|
|
@ -39,7 +33,7 @@
|
|||
(define (graph-add-node g n1) (dict-extend g n1 ()))
|
||||
|
||||
(define (graph-from-edges edge-list)
|
||||
(if (null edge-list)
|
||||
(if (null? edge-list)
|
||||
(graph-empty)
|
||||
(graph-connect (graph-from-edges (cdr edge-list))
|
||||
(caar edge-list)
|
||||
|
|
@ -52,17 +46,17 @@
|
|||
(map
|
||||
(lambda (n)
|
||||
(let ((color-pair (assq n coloring)))
|
||||
(if (consp color-pair) (cdr color-pair) ())))
|
||||
(if (pair? color-pair) (cdr color-pair) ())))
|
||||
(graph-neighbors g node-to-color)))))
|
||||
|
||||
(define (try-each f lst)
|
||||
(if (null lst) #f
|
||||
(if (null? lst) #f
|
||||
(let ((ret (f (car lst))))
|
||||
(if ret ret (try-each f (cdr lst))))))
|
||||
|
||||
(define (color-node g coloring colors uncolored-nodes color)
|
||||
(cond
|
||||
((null uncolored-nodes) coloring)
|
||||
((null? uncolored-nodes) coloring)
|
||||
((node-colorable? g coloring (car uncolored-nodes) color)
|
||||
(let ((new-coloring
|
||||
(cons (cons (car uncolored-nodes) color) coloring)))
|
||||
|
|
@ -71,8 +65,8 @@
|
|||
colors)))))
|
||||
|
||||
(define (color-graph g colors)
|
||||
(if (null colors)
|
||||
(and (null (graph-nodes g)) ())
|
||||
(if (null? colors)
|
||||
(and (null? (graph-nodes g)) ())
|
||||
(color-node g () colors (graph-nodes g) (car colors))))
|
||||
|
||||
(define (color-pairs pairs colors)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
(define (cond->if form)
|
||||
(cond-clauses->if (cdr form)))
|
||||
(define (cond-clauses->if lst)
|
||||
(if (atom lst)
|
||||
(if (atom? lst)
|
||||
lst
|
||||
(let ((clause (car lst)))
|
||||
`(if ,(car clause)
|
||||
|
|
@ -10,11 +10,11 @@
|
|||
,(cond-clauses->if (cdr lst))))))
|
||||
|
||||
(define (begin->cps forms k)
|
||||
(cond ((atom forms) `(,k ,forms))
|
||||
((null (cdr forms)) (cps- (car forms) k))
|
||||
(T (let ((_ (gensym))) ; var to bind ignored value
|
||||
(cps- (car forms) `(lambda (,_)
|
||||
,(begin->cps (cdr forms) k)))))))
|
||||
(cond ((atom? forms) `(,k ,forms))
|
||||
((null? (cdr forms)) (cps- (car forms) k))
|
||||
(#t (let ((_ (gensym))) ; var to bind ignored value
|
||||
(cps- (car forms) `(lambda (,_)
|
||||
,(begin->cps (cdr forms) k)))))))
|
||||
|
||||
(define-macro (lambda/cc args body)
|
||||
`(rplaca (lambda ,args ,body) 'lambda/cc))
|
||||
|
|
@ -44,7 +44,7 @@
|
|||
|
||||
(define (rest->cps xformer form k argsyms)
|
||||
(let ((el (car form)))
|
||||
(if (or (atom el) (constant? el))
|
||||
(if (or (atom? el) (constant? el))
|
||||
(xformer (cdr form) k (cons el argsyms))
|
||||
(let ((g (gensym)))
|
||||
(cps- el `(lambda (,g)
|
||||
|
|
@ -58,17 +58,17 @@
|
|||
|
||||
; (f x) => (cps- f `(lambda (F) ,(cps- x `(lambda (X) (F ,k X)))))
|
||||
(define (app->cps form k argsyms)
|
||||
(cond ((atom form)
|
||||
(cond ((atom? form)
|
||||
(let ((r (reverse argsyms)))
|
||||
(make-funcall/cc (car r) k (cdr r))))
|
||||
(T (rest->cps app->cps form k argsyms))))
|
||||
(#t (rest->cps app->cps form k argsyms))))
|
||||
|
||||
; (+ x) => (cps- x `(lambda (X) (,k (+ X))))
|
||||
(define (builtincall->cps form k)
|
||||
(prim->cps (cdr form) k (list (car form))))
|
||||
(define (prim->cps form k argsyms)
|
||||
(cond ((atom form) `(,k ,(reverse argsyms)))
|
||||
(T (rest->cps prim->cps form k argsyms))))
|
||||
(cond ((atom? form) `(,k ,(reverse argsyms)))
|
||||
(#t (rest->cps prim->cps form k argsyms))))
|
||||
|
||||
(define *top-k* (gensym))
|
||||
(set *top-k* identity)
|
||||
|
|
@ -80,7 +80,7 @@
|
|||
(cps- (macroexpand form) *top-k*)))))
|
||||
(define (cps- form k)
|
||||
(let ((g (gensym)))
|
||||
(cond ((or (atom form) (constant? form))
|
||||
(cond ((or (atom? form) (constant? form))
|
||||
`(,k ,form))
|
||||
|
||||
((eq (car form) 'lambda)
|
||||
|
|
@ -96,7 +96,7 @@
|
|||
(let ((test (cadr form))
|
||||
(then (caddr form))
|
||||
(else (cadddr form)))
|
||||
(if (atom k)
|
||||
(if (atom? k)
|
||||
(cps- test `(lambda (,g)
|
||||
(if ,g
|
||||
,(cps- then k)
|
||||
|
|
@ -105,9 +105,9 @@
|
|||
,(cps- form g)))))
|
||||
|
||||
((eq (car form) 'and)
|
||||
(cond ((atom (cdr form)) `(,k T))
|
||||
((atom (cddr form)) (cps- (cadr form) k))
|
||||
(T
|
||||
(cond ((atom? (cdr form)) `(,k #t))
|
||||
((atom? (cddr form)) (cps- (cadr form) k))
|
||||
(#t
|
||||
(if (atom k)
|
||||
(cps- (cadr form)
|
||||
`(lambda (,g)
|
||||
|
|
@ -117,10 +117,10 @@
|
|||
,(cps- form g))))))
|
||||
|
||||
((eq (car form) 'or)
|
||||
(cond ((atom (cdr form)) `(,k #f))
|
||||
((atom (cddr form)) (cps- (cadr form) k))
|
||||
(T
|
||||
(if (atom k)
|
||||
(cond ((atom? (cdr form)) `(,k #f))
|
||||
((atom? (cddr form)) (cps- (cadr form) k))
|
||||
(#t
|
||||
(if (atom? k)
|
||||
(cps- (cadr form)
|
||||
`(lambda (,g)
|
||||
(if ,g (,k ,g)
|
||||
|
|
@ -168,23 +168,23 @@
|
|||
(eq (caar form) 'lambda))
|
||||
(let ((largs (cadr (car form)))
|
||||
(lbody (caddr (car form))))
|
||||
(cond ((null largs) ; ((lambda () body))
|
||||
(cond ((null? largs) ; ((lambda () body))
|
||||
(cps- lbody k))
|
||||
((symbolp largs) ; ((lambda x body) args...)
|
||||
((symbol? largs) ; ((lambda x body) args...)
|
||||
(cps- `((lambda (,largs) ,lbody) (list ,@(cdr form))) k))
|
||||
(T
|
||||
(#t
|
||||
(cps- (cadr form) `(lambda (,(car largs))
|
||||
,(cps- `((lambda ,(cdr largs) ,lbody)
|
||||
,@(cddr form))
|
||||
k)))))))
|
||||
|
||||
(T
|
||||
(#t
|
||||
(app->cps form k ())))))
|
||||
|
||||
; (lambda (args...) (f args...)) => f
|
||||
; but only for constant, builtin f
|
||||
(define (η-reduce form)
|
||||
(cond ((or (atom form) (constant? form)) form)
|
||||
(cond ((or (atom? form) (constant? form)) form)
|
||||
((and (eq (car form) 'lambda)
|
||||
(let ((body (caddr form))
|
||||
(args (cadr form)))
|
||||
|
|
@ -192,16 +192,16 @@
|
|||
(equal (cdr body) args)
|
||||
(constant? (car (caddr form))))))
|
||||
(car (caddr form)))
|
||||
(T (map η-reduce form))))
|
||||
(#t (map η-reduce form))))
|
||||
|
||||
(define (contains x form)
|
||||
(or (eq form x)
|
||||
(any (lambda (p) (contains x p)) form)))
|
||||
|
||||
(define (β-reduce form)
|
||||
(if (or (atom form) (constant? form))
|
||||
(if (or (atom? form) (constant? form))
|
||||
form
|
||||
(β-reduce- (map β-reduce form))))
|
||||
(β-reduce- (map β-reduce form))))
|
||||
|
||||
(define (β-reduce- form)
|
||||
; ((lambda (f) (f arg)) X) => (X arg)
|
||||
|
|
@ -215,7 +215,7 @@
|
|||
(= (length args) 1)
|
||||
(eq (car body) (car args))
|
||||
(not (eq (cadr body) (car args)))
|
||||
(symbolp (cadr body)))))
|
||||
(symbol? (cadr body)))))
|
||||
`(,(cadr form)
|
||||
,(cadr (caddr (car form)))))
|
||||
|
||||
|
|
@ -230,7 +230,7 @@
|
|||
((and (= (length form) 2)
|
||||
(pair? (car form))
|
||||
(eq (caar form) 'lambda)
|
||||
(or (atom (cadr form)) (constant? (cadr form)))
|
||||
(or (atom? (cadr form)) (constant? (cadr form)))
|
||||
(let ((args (cadr (car form)))
|
||||
(s (cadr form))
|
||||
(body (caddr (car form))))
|
||||
|
|
@ -247,7 +247,7 @@
|
|||
,s
|
||||
,@params)))))))
|
||||
|
||||
(T form)))
|
||||
(#t form)))
|
||||
|
||||
(define-macro (with-delimited-continuations . code)
|
||||
(cps (f-body code)))
|
||||
|
|
@ -287,7 +287,7 @@
|
|||
(cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
|
||||
'(a 1 b b c)))
|
||||
|
||||
T
|
||||
#t
|
||||
|
||||
#|
|
||||
todo:
|
||||
|
|
|
|||
|
|
@ -791,7 +791,7 @@ static value_t cvalue_array_aset(value_t *args)
|
|||
{
|
||||
char *data; ulong_t index;
|
||||
fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype;
|
||||
check_addr_args("aset", args[0], args[1], &data, &index);
|
||||
check_addr_args("aset!", args[0], args[1], &data, &index);
|
||||
char *dest = data + index*eltype->size;
|
||||
cvalue_init(eltype, args[2], dest);
|
||||
return args[2];
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ static char *builtin_names[] =
|
|||
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
|
||||
"eval", "eval*", "apply", "prog1", "raise",
|
||||
"+", "-", "*", "/", "<", "~", "&", "!", "$",
|
||||
"vector", "aref", "aset", "length", "assq", "compare", "for",
|
||||
"vector", "aref", "aset!", "length", "assq", "compare", "for",
|
||||
"", "", "" };
|
||||
|
||||
#define N_STACK 98304
|
||||
|
|
@ -1004,19 +1004,19 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
break;
|
||||
case F_ASET:
|
||||
argcount("aset", nargs, 3);
|
||||
argcount("aset!", nargs, 3);
|
||||
e = Stack[SP-3];
|
||||
if (isvector(e)) {
|
||||
i = tofixnum(Stack[SP-2], "aset");
|
||||
i = tofixnum(Stack[SP-2], "aset!");
|
||||
if (__unlikely((unsigned)i >= vector_size(e)))
|
||||
bounds_error("aref", v, Stack[SP-1]);
|
||||
bounds_error("aset!", v, Stack[SP-1]);
|
||||
vector_elt(e, i) = (v=Stack[SP-1]);
|
||||
}
|
||||
else if (isarray(e)) {
|
||||
v = cvalue_array_aset(&Stack[SP-3]);
|
||||
}
|
||||
else {
|
||||
type_error("aset", "sequence", e);
|
||||
type_error("aset!", "sequence", e);
|
||||
}
|
||||
break;
|
||||
case F_ATOM:
|
||||
|
|
|
|||
|
|
@ -520,14 +520,22 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type,
|
|||
else
|
||||
HPOS+=ios_printf(f, "%s", rep);
|
||||
}
|
||||
else if (d == 0) {
|
||||
if (1/d < 0)
|
||||
HPOS+=ios_printf(f, "-0.0%s", type==floatsym?"f":"");
|
||||
else
|
||||
HPOS+=ios_printf(f, "0.0%s", type==floatsym?"f":"");
|
||||
}
|
||||
else {
|
||||
snprint_real(buf, sizeof(buf), d, 0, ndec, 3, 10);
|
||||
if (weak || princ || strpbrk(buf, ".eE")) {
|
||||
outs(buf, f);
|
||||
int hasdec = (strpbrk(buf, ".eE") != NULL);
|
||||
outs(buf, f);
|
||||
if (weak || princ || hasdec) {
|
||||
if (type == floatsym) outc('f', f);
|
||||
}
|
||||
else {
|
||||
HPOS+=ios_printf(f, "#%s(%s)", symbol_name(type), buf);
|
||||
if (!hasdec) outs(".0", f);
|
||||
if (type==floatsym) outc('f', f);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -16,7 +16,16 @@ static int symchar(char c)
|
|||
return (!isspace(c) && !strchr(special, c));
|
||||
}
|
||||
|
||||
static int isnumtok(char *tok, value_t *pval)
|
||||
static int isdigit_base(char c, int base)
|
||||
{
|
||||
if (base < 11)
|
||||
return (c >= '0' && c < '0'+base);
|
||||
return ((c >= '0' && c <= '9') ||
|
||||
(c >= 'a' && c < 'a'+base-10) ||
|
||||
(c >= 'A' && c < 'A'+base-10));
|
||||
}
|
||||
|
||||
static int isnumtok_base(char *tok, value_t *pval, int base)
|
||||
{
|
||||
char *end;
|
||||
int64_t i64;
|
||||
|
|
@ -24,50 +33,63 @@ static int isnumtok(char *tok, value_t *pval)
|
|||
double d;
|
||||
if (*tok == '\0')
|
||||
return 0;
|
||||
if (!(tok[0]=='0' && isdigit(tok[1])) &&
|
||||
strpbrk(tok, ".eEpP")) {
|
||||
if (strpbrk(tok, ".eEpP")) {
|
||||
d = strtod(tok, &end);
|
||||
if (*end == '\0') {
|
||||
if (pval) *pval = mk_double(d);
|
||||
return 1;
|
||||
}
|
||||
if (end > tok && end[0] == 'f' && end[1] == '\0') {
|
||||
// floats can end in f or f0
|
||||
if (end > tok && end[0] == 'f' &&
|
||||
(end[1] == '\0' ||
|
||||
(end[1] == '0' && end[2] == '\0'))) {
|
||||
if (pval) *pval = mk_float((float)d);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
if (tok[0] == '+') {
|
||||
if (!strcmp(tok,"+NaN")) {
|
||||
if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {
|
||||
if (pval) *pval = mk_double(D_PNAN);
|
||||
return 1;
|
||||
}
|
||||
if (!strcmp(tok,"+Inf")) {
|
||||
if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {
|
||||
if (pval) *pval = mk_double(D_PINF);
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
else if (tok[0] == '-') {
|
||||
if (!strcmp(tok,"-NaN")) {
|
||||
if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {
|
||||
if (pval) *pval = mk_double(D_NNAN);
|
||||
return 1;
|
||||
}
|
||||
if (!strcmp(tok,"-Inf")) {
|
||||
if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {
|
||||
if (pval) *pval = mk_double(D_NINF);
|
||||
return 1;
|
||||
}
|
||||
i64 = strtoll(tok, &end, 0);
|
||||
i64 = strtoll(tok, &end, base);
|
||||
if (pval) *pval = return_from_int64(i64);
|
||||
return (*end == '\0');
|
||||
}
|
||||
else if (!isdigit(tok[0])) {
|
||||
return 0;
|
||||
}
|
||||
ui64 = strtoull(tok, &end, 0);
|
||||
ui64 = strtoull(tok, &end, base);
|
||||
if (pval) *pval = return_from_uint64(ui64);
|
||||
return (*end == '\0');
|
||||
}
|
||||
|
||||
static int isnumtok(char *tok, value_t *pval)
|
||||
{
|
||||
return isnumtok_base(tok, pval, 0);
|
||||
}
|
||||
|
||||
static int read_numtok(char *tok, value_t *pval, int base)
|
||||
{
|
||||
int result;
|
||||
errno = 0;
|
||||
result = isnumtok_base(tok, pval, base);
|
||||
if (errno) lerror(ParseError, "read: overflow in numeric constant");
|
||||
return result;
|
||||
}
|
||||
|
||||
static u_int32_t toktype = TOK_NONE;
|
||||
static value_t tokval;
|
||||
static char buf[256];
|
||||
|
|
@ -148,7 +170,7 @@ static u_int32_t peek(ios_t *f)
|
|||
{
|
||||
char c, *end;
|
||||
fixnum_t x;
|
||||
int ch;
|
||||
int ch, base;
|
||||
|
||||
if (toktype != TOK_NONE)
|
||||
return toktype;
|
||||
|
|
@ -176,30 +198,30 @@ static u_int32_t peek(ios_t *f)
|
|||
toktype = TOK_DOUBLEQUOTE;
|
||||
}
|
||||
else if (c == '#') {
|
||||
ch = ios_getc(f);
|
||||
ch = ios_getc(f); c = (char)ch;
|
||||
if (ch == IOS_EOF)
|
||||
lerror(ParseError, "read: invalid read macro");
|
||||
if ((char)ch == '.') {
|
||||
if (c == '.') {
|
||||
toktype = TOK_SHARPDOT;
|
||||
}
|
||||
else if ((char)ch == '\'') {
|
||||
else if (c == '\'') {
|
||||
toktype = TOK_SHARPQUOTE;
|
||||
}
|
||||
else if ((char)ch == '\\') {
|
||||
else if (c == '\\') {
|
||||
uint32_t cval;
|
||||
if (ios_getutf8(f, &cval) == IOS_EOF)
|
||||
lerror(ParseError, "read: end of input in character constant");
|
||||
toktype = TOK_NUM;
|
||||
tokval = mk_wchar(cval);
|
||||
}
|
||||
else if ((char)ch == '(') {
|
||||
else if (c == '(') {
|
||||
toktype = TOK_SHARPOPEN;
|
||||
}
|
||||
else if ((char)ch == '<') {
|
||||
else if (c == '<') {
|
||||
lerror(ParseError, "read: unreadable object");
|
||||
}
|
||||
else if (isdigit((char)ch)) {
|
||||
read_token(f, (char)ch, 1);
|
||||
else if (isdigit(c)) {
|
||||
read_token(f, c, 1);
|
||||
c = (char)ios_getc(f);
|
||||
if (c == '#')
|
||||
toktype = TOK_BACKREF;
|
||||
|
|
@ -213,14 +235,14 @@ static u_int32_t peek(ios_t *f)
|
|||
lerror(ParseError, "read: invalid label");
|
||||
tokval = fixnum(x);
|
||||
}
|
||||
else if ((char)ch == '!') {
|
||||
else if (c == '!') {
|
||||
// #! single line comment for shbang script support
|
||||
do {
|
||||
ch = ios_getc(f);
|
||||
} while (ch != IOS_EOF && (char)ch != '\n');
|
||||
return peek(f);
|
||||
}
|
||||
else if ((char)ch == '|') {
|
||||
else if (c == '|') {
|
||||
// multiline comment
|
||||
int commentlevel=1;
|
||||
while (1) {
|
||||
|
|
@ -250,10 +272,10 @@ static u_int32_t peek(ios_t *f)
|
|||
// this was whitespace, so keep peeking
|
||||
return peek(f);
|
||||
}
|
||||
else if ((char)ch == ';') {
|
||||
else if (c == ';') {
|
||||
toktype = TOK_SHARPSEMI;
|
||||
}
|
||||
else if ((char)ch == ':') {
|
||||
else if (c == ':') {
|
||||
// gensym
|
||||
ch = ios_getc(f);
|
||||
if ((char)ch == 'g')
|
||||
|
|
@ -266,8 +288,18 @@ static u_int32_t peek(ios_t *f)
|
|||
toktype = TOK_GENSYM;
|
||||
tokval = fixnum(x);
|
||||
}
|
||||
else if (symchar((char)ch)) {
|
||||
else if (symchar(c)) {
|
||||
read_token(f, ch, 0);
|
||||
|
||||
if (((c == 'b' && (base= 2)) ||
|
||||
(c == 'o' && (base= 8)) ||
|
||||
(c == 'd' && (base=10)) ||
|
||||
(c == 'x' && (base=16))) && isdigit_base(buf[1],base)) {
|
||||
if (!read_numtok(&buf[1], &tokval, base))
|
||||
lerror(ParseError, "read: invalid base %d constant", base);
|
||||
return (toktype=TOK_NUM);
|
||||
}
|
||||
|
||||
toktype = TOK_SHARPSYM;
|
||||
tokval = symbol(buf);
|
||||
}
|
||||
|
|
@ -293,12 +325,8 @@ static u_int32_t peek(ios_t *f)
|
|||
return (toktype=TOK_DOT);
|
||||
}
|
||||
else {
|
||||
errno = 0;
|
||||
if (isnumtok(buf, &tokval)) {
|
||||
if (errno)
|
||||
lerror(ParseError,"read: overflow in numeric constant");
|
||||
if (read_numtok(buf, &tokval, 0))
|
||||
return (toktype=TOK_NUM);
|
||||
}
|
||||
}
|
||||
}
|
||||
toktype = TOK_SYM;
|
||||
|
|
|
|||
|
|
@ -6,28 +6,17 @@
|
|||
(set-constant! 'eq eq?)
|
||||
(set-constant! 'eqv eqv?)
|
||||
(set-constant! 'equal equal?)
|
||||
(set-constant! 'booleanp boolean?)
|
||||
(set-constant! 'consp pair?)
|
||||
(set-constant! 'null null?)
|
||||
(set-constant! 'atom atom?)
|
||||
(set-constant! 'symbolp symbol?)
|
||||
(set-constant! 'numberp number?)
|
||||
(set-constant! 'boundp bound?)
|
||||
(set-constant! 'builtinp builtin?)
|
||||
(set-constant! 'vectorp vector?)
|
||||
(set-constant! 'fixnump fixnum?)
|
||||
(set-constant! 'rplaca set-car!)
|
||||
(set-constant! 'rplacd set-cdr!)
|
||||
(set-constant! 'char? (lambda (x) (eq? (typeof x) 'wchar)))
|
||||
(set-constant! 'T #t)
|
||||
|
||||
; convert a sequence of body statements to a single expression.
|
||||
; this allows define, defun, defmacro, let, etc. to contain multiple
|
||||
; body expressions as in Common Lisp.
|
||||
(set! f-body (lambda (e)
|
||||
(cond ((atom e) e)
|
||||
(cond ((atom? e) e)
|
||||
((eq (cdr e) ()) (car e))
|
||||
(T (cons 'begin e)))))
|
||||
(#t (cons 'begin e)))))
|
||||
|
||||
(set-syntax! 'define-macro
|
||||
(lambda (form . body)
|
||||
|
|
@ -38,7 +27,7 @@
|
|||
(list (list 'lambda (list name) (list 'set! name fn)) #f))
|
||||
|
||||
(define-macro (define form . body)
|
||||
(if (symbolp form)
|
||||
(if (symbol? form)
|
||||
(list 'set! form (car body))
|
||||
(list 'set! (car form) (list 'lambda (cdr form) (f-body body)))))
|
||||
|
||||
|
|
@ -47,73 +36,73 @@
|
|||
(define (identity x) x)
|
||||
|
||||
(define (map f lst)
|
||||
(if (atom lst) lst
|
||||
(if (atom? lst) lst
|
||||
(cons (f (car lst)) (map f (cdr lst)))))
|
||||
|
||||
(define-macro (let binds . body)
|
||||
(cons (list 'lambda
|
||||
(map (lambda (c) (if (consp c) (car c) c)) binds)
|
||||
(map (lambda (c) (if (pair? c) (car c) c)) binds)
|
||||
(f-body body))
|
||||
(map (lambda (c) (if (consp c) (cadr c) #f)) binds)))
|
||||
(map (lambda (c) (if (pair? c) (cadr c) #f)) binds)))
|
||||
|
||||
(define (nconc . lsts)
|
||||
(cond ((null lsts) ())
|
||||
((null (cdr lsts)) (car lsts))
|
||||
((null (car lsts)) (apply nconc (cdr lsts)))
|
||||
(T (prog1 (car lsts)
|
||||
(rplacd (last (car lsts))
|
||||
(apply nconc (cdr lsts)))))))
|
||||
(cond ((null? lsts) ())
|
||||
((null? (cdr lsts)) (car lsts))
|
||||
((null? (car lsts)) (apply nconc (cdr lsts)))
|
||||
(#t (prog1 (car lsts)
|
||||
(rplacd (last (car lsts))
|
||||
(apply nconc (cdr lsts)))))))
|
||||
|
||||
(define (append . lsts)
|
||||
(cond ((null lsts) ())
|
||||
((null (cdr lsts)) (car lsts))
|
||||
(T ((label append2 (lambda (l d)
|
||||
(if (null l) d
|
||||
(cons (car l)
|
||||
(append2 (cdr l) d)))))
|
||||
(car lsts) (apply append (cdr lsts))))))
|
||||
(cond ((null? lsts) ())
|
||||
((null? (cdr lsts)) (car lsts))
|
||||
(#t ((label append2 (lambda (l d)
|
||||
(if (null? l) d
|
||||
(cons (car l)
|
||||
(append2 (cdr l) d)))))
|
||||
(car lsts) (apply append (cdr lsts))))))
|
||||
|
||||
(define (member item lst)
|
||||
(cond ((atom lst) #f)
|
||||
((equal (car lst) item) lst)
|
||||
(T (member item (cdr lst)))))
|
||||
(cond ((atom? lst) #f)
|
||||
((equal (car lst) item) lst)
|
||||
(#t (member item (cdr lst)))))
|
||||
(define (memq item lst)
|
||||
(cond ((atom lst) #f)
|
||||
((eq (car lst) item) lst)
|
||||
(T (memq item (cdr lst)))))
|
||||
(cond ((atom? lst) #f)
|
||||
((eq (car lst) item) lst)
|
||||
(#t (memq item (cdr lst)))))
|
||||
(define (memv item lst)
|
||||
(cond ((atom lst) #f)
|
||||
((eqv (car lst) item) lst)
|
||||
(T (memv item (cdr lst)))))
|
||||
(cond ((atom? lst) #f)
|
||||
((eqv (car lst) item) lst)
|
||||
(#t (memv item (cdr lst)))))
|
||||
|
||||
(define (assoc item lst)
|
||||
(cond ((atom lst) #f)
|
||||
((equal (caar lst) item) (car lst))
|
||||
(T (assoc item (cdr lst)))))
|
||||
(cond ((atom? lst) #f)
|
||||
((equal (caar lst) item) (car lst))
|
||||
(#t (assoc item (cdr lst)))))
|
||||
(define (assv item lst)
|
||||
(cond ((atom lst) #f)
|
||||
((eqv (caar lst) item) (car lst))
|
||||
(T (assv item (cdr lst)))))
|
||||
(cond ((atom? lst) #f)
|
||||
((eqv (caar lst) item) (car lst))
|
||||
(#t (assv item (cdr lst)))))
|
||||
|
||||
(define (macrocall? e) (and (symbolp (car e))
|
||||
(define (macrocall? e) (and (symbol? (car e))
|
||||
(symbol-syntax (car e))))
|
||||
|
||||
(define (function? x)
|
||||
(or (builtinp x)
|
||||
(and (consp x) (eq (car x) 'lambda))))
|
||||
(or (builtin? x)
|
||||
(and (pair? x) (eq (car x) 'lambda))))
|
||||
(define procedure? function?)
|
||||
|
||||
(define (macroexpand-1 e)
|
||||
(if (atom e) e
|
||||
(if (atom? e) e
|
||||
(let ((f (macrocall? e)))
|
||||
(if f (apply f (cdr e))
|
||||
e))))
|
||||
|
||||
; convert to proper list, i.e. remove "dots", and append
|
||||
(define (append.2 l tail)
|
||||
(cond ((null l) tail)
|
||||
((atom l) (cons l tail))
|
||||
(T (cons (car l) (append.2 (cdr l) tail)))))
|
||||
(cond ((null? l) tail)
|
||||
((atom? l) (cons l tail))
|
||||
(#t (cons (car l) (append.2 (cdr l) tail)))))
|
||||
|
||||
(define (cadr x) (car (cdr x)))
|
||||
|
||||
|
|
@ -124,27 +113,27 @@
|
|||
((label mexpand
|
||||
(lambda (e env f)
|
||||
(begin
|
||||
(while (and (consp e)
|
||||
(while (and (pair? e)
|
||||
(not (member (car e) env))
|
||||
(set! f (macrocall? e)))
|
||||
(set! e (apply f (cdr e))))
|
||||
(cond ((and (consp e)
|
||||
(cond ((and (pair? e)
|
||||
(not (eq (car e) 'quote)))
|
||||
(let ((newenv
|
||||
(if (and (eq (car e) 'lambda)
|
||||
(consp (cdr e)))
|
||||
(pair? (cdr e)))
|
||||
(append.2 (cadr e) env)
|
||||
env)))
|
||||
(map (lambda (x) (mexpand x newenv ())) e)))
|
||||
;((and (symbolp e) (constant? e)) (eval e))
|
||||
;((and (symbolp e)
|
||||
;((and (symbol? e) (constant? e)) (eval e))
|
||||
;((and (symbol? e)
|
||||
; (not (member e *special-forms*))
|
||||
; (not (member e env))) (cons '%top e))
|
||||
(T e)))))
|
||||
(#t e)))))
|
||||
e () ()))
|
||||
|
||||
(define-macro (define form . body)
|
||||
(if (symbolp form)
|
||||
(if (symbol? form)
|
||||
(list 'set! form (car body))
|
||||
(list 'set! (car form)
|
||||
(macroexpand (list 'lambda (cdr form) (f-body body))))))
|
||||
|
|
@ -163,6 +152,7 @@
|
|||
(define (1+ n) (+ n 1))
|
||||
(define (1- n) (- n 1))
|
||||
(define (mod x y) (- x (* (/ x y) y)))
|
||||
(define remainder mod)
|
||||
(define (abs x) (if (< x 0) (- x) x))
|
||||
(define K prog1) ; K combinator ;)
|
||||
|
||||
|
|
@ -180,99 +170,101 @@
|
|||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
|
||||
(define (every pred lst)
|
||||
(or (atom lst)
|
||||
(or (atom? lst)
|
||||
(and (pred (car lst))
|
||||
(every pred (cdr lst)))))
|
||||
|
||||
(define (any pred lst)
|
||||
(and (consp lst)
|
||||
(and (pair? lst)
|
||||
(or (pred (car lst))
|
||||
(any pred (cdr lst)))))
|
||||
|
||||
(define (listp a) (or (null a) (consp a)))
|
||||
(define (list? a) (or (null a) (and (pair? a) (list? (cdr a)))))
|
||||
(define (listp a) (or (null? a) (pair? a)))
|
||||
(define (list? a) (or (null? a) (and (pair? a) (list? (cdr a)))))
|
||||
|
||||
(define (nthcdr lst n)
|
||||
(if (<= n 0) lst
|
||||
(nthcdr (cdr lst) (- n 1))))
|
||||
(define list-tail nthcdr)
|
||||
|
||||
(define (list-ref lst n)
|
||||
(car (nthcdr lst n)))
|
||||
|
||||
(define (list* . l)
|
||||
(if (atom (cdr l))
|
||||
(if (atom? (cdr l))
|
||||
(car l)
|
||||
(cons (car l) (apply list* (cdr l)))))
|
||||
|
||||
(define (nlist* . l)
|
||||
(if (atom (cdr l))
|
||||
(if (atom? (cdr l))
|
||||
(car l)
|
||||
(rplacd l (apply nlist* (cdr l)))))
|
||||
|
||||
(define (lastcdr l)
|
||||
(if (atom l) l
|
||||
(if (atom? l) l
|
||||
(lastcdr (cdr l))))
|
||||
|
||||
(define (last l)
|
||||
(cond ((atom l) l)
|
||||
((atom (cdr l)) l)
|
||||
(T (last (cdr l)))))
|
||||
(cond ((atom? l) l)
|
||||
((atom? (cdr l)) l)
|
||||
(#t (last (cdr l)))))
|
||||
(define last-pair last)
|
||||
|
||||
(define (map! f lst)
|
||||
(prog1 lst
|
||||
(while (consp lst)
|
||||
(while (pair? lst)
|
||||
(rplaca lst (f (car lst)))
|
||||
(set! lst (cdr lst)))))
|
||||
|
||||
(define (mapcar f . lsts)
|
||||
((label mapcar-
|
||||
(lambda (lsts)
|
||||
(cond ((null lsts) (f))
|
||||
((atom (car lsts)) (car lsts))
|
||||
(T (cons (apply f (map car lsts))
|
||||
(mapcar- (map cdr lsts)))))))
|
||||
(cond ((null? lsts) (f))
|
||||
((atom? (car lsts)) (car lsts))
|
||||
(#t (cons (apply f (map car lsts))
|
||||
(mapcar- (map cdr lsts)))))))
|
||||
lsts))
|
||||
|
||||
(define (transpose M) (apply mapcar (cons list M)))
|
||||
|
||||
(define (filter pred lst) (filter- pred lst ()))
|
||||
(define (filter- pred lst accum)
|
||||
(cond ((null lst) accum)
|
||||
(cond ((null? lst) accum)
|
||||
((pred (car lst))
|
||||
(filter- pred (cdr lst) (cons (car lst) accum)))
|
||||
(T
|
||||
(#t
|
||||
(filter- pred (cdr lst) accum))))
|
||||
|
||||
(define (separate pred lst) (separate- pred lst () ()))
|
||||
(define (separate- pred lst yes no)
|
||||
(cond ((null lst) (cons yes no))
|
||||
(cond ((null? lst) (cons yes no))
|
||||
((pred (car lst))
|
||||
(separate- pred (cdr lst) (cons (car lst) yes) no))
|
||||
(T
|
||||
(#t
|
||||
(separate- pred (cdr lst) yes (cons (car lst) no)))))
|
||||
|
||||
(define (foldr f zero lst)
|
||||
(if (null lst) zero
|
||||
(if (null? lst) zero
|
||||
(f (car lst) (foldr f zero (cdr lst)))))
|
||||
|
||||
(define (foldl f zero lst)
|
||||
(if (null lst) zero
|
||||
(if (null? lst) zero
|
||||
(foldl f (f (car lst) zero) (cdr lst))))
|
||||
|
||||
(define (reverse lst) (foldl cons () lst))
|
||||
|
||||
(define (copy-list l)
|
||||
(if (atom l) l
|
||||
(if (atom? l) l
|
||||
(cons (car l)
|
||||
(copy-list (cdr l)))))
|
||||
(define (copy-tree l)
|
||||
(if (atom l) l
|
||||
(if (atom? l) l
|
||||
(cons (copy-tree (car l))
|
||||
(copy-tree (cdr l)))))
|
||||
|
||||
(define (nreverse l)
|
||||
(let ((prev ()))
|
||||
(while (consp l)
|
||||
(while (pair? l)
|
||||
(set! l (prog1 (cdr l)
|
||||
(rplacd l (prog1 prev
|
||||
(set! prev l))))))
|
||||
|
|
@ -324,7 +316,7 @@
|
|||
(define-macro (catch tag expr)
|
||||
(let ((e (gensym)))
|
||||
`(trycatch ,expr
|
||||
(lambda (,e) (if (and (consp ,e)
|
||||
(lambda (,e) (if (and (pair? ,e)
|
||||
(eq (car ,e) 'thrown-value)
|
||||
(eq (cadr ,e) ,tag))
|
||||
(caddr ,e)
|
||||
|
|
@ -354,15 +346,15 @@
|
|||
extype))
|
||||
(todo (cddr catc)))
|
||||
`(,(if specific
|
||||
; exception matching logic
|
||||
; exception matching logic
|
||||
`(or (eq ,e ',extype)
|
||||
(and (consp ,e)
|
||||
(and (pair? ,e)
|
||||
(eq (car ,e)
|
||||
',extype)))
|
||||
T); (catch (e) ...), match anything
|
||||
#t); (catch (e) ...), match anything
|
||||
(let ((,var ,e)) (begin ,@todo)))))
|
||||
catches)
|
||||
(T (raise ,e))))) ; no matches, reraise
|
||||
(#t (raise ,e))))) ; no matches, reraise
|
||||
(if final
|
||||
(if catches
|
||||
; form with both catch and finally
|
||||
|
|
@ -400,15 +392,15 @@
|
|||
(cddar rplacd cdar)
|
||||
(cdddr rplacd cddr)
|
||||
(list-ref rplaca nthcdr)
|
||||
(get put identity)
|
||||
(aref aset identity)
|
||||
(get put! identity)
|
||||
(aref aset! identity)
|
||||
(symbol-syntax set-syntax! identity)))
|
||||
|
||||
(define (setf-place-mutator place val)
|
||||
(if (symbolp place)
|
||||
(if (symbol? place)
|
||||
(list 'set! place val)
|
||||
(let ((mutator (assq (car place) *setf-place-list*)))
|
||||
(if (null mutator)
|
||||
(if (null? mutator)
|
||||
(error "setf: unknown place " (car place))
|
||||
(if (eq (caddr mutator) 'identity)
|
||||
(cons (cadr mutator) (append (cdr place) (list val)))
|
||||
|
|
@ -420,7 +412,7 @@
|
|||
(f-body
|
||||
((label setf-
|
||||
(lambda (args)
|
||||
(if (null args)
|
||||
(if (null? args)
|
||||
()
|
||||
(cons (setf-place-mutator (car args) (cadr args))
|
||||
(setf- (cddr args))))))
|
||||
|
|
@ -439,8 +431,8 @@
|
|||
l))
|
||||
|
||||
(define (self-evaluating? x)
|
||||
(or (and (atom x)
|
||||
(not (symbolp x)))
|
||||
(or (and (atom? x)
|
||||
(not (symbol? x)))
|
||||
(and (constant? x)
|
||||
(eq x (eval x)))))
|
||||
|
||||
|
|
@ -448,54 +440,54 @@
|
|||
(define-macro (backquote x) (bq-process x))
|
||||
|
||||
(define (splice-form? x)
|
||||
(or (and (consp x) (or (eq (car x) '*comma-at*)
|
||||
(or (and (pair? x) (or (eq (car x) '*comma-at*)
|
||||
(eq (car x) '*comma-dot*)))
|
||||
(eq x '*comma*)))
|
||||
|
||||
(define (bq-process x)
|
||||
(cond ((self-evaluating? x)
|
||||
(if (vectorp x)
|
||||
(if (vector? x)
|
||||
(let ((body (bq-process (vector-to-list x))))
|
||||
(if (eq (car body) 'list)
|
||||
(cons vector (cdr body))
|
||||
(list apply vector body)))
|
||||
x))
|
||||
((atom x) (list 'quote x))
|
||||
((atom? x) (list 'quote x))
|
||||
((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
|
||||
((eq (car x) '*comma*) (cadr x))
|
||||
((not (any splice-form? x))
|
||||
(let ((lc (lastcdr x))
|
||||
(forms (map bq-bracket1 x)))
|
||||
(if (null lc)
|
||||
(if (null? lc)
|
||||
(cons 'list forms)
|
||||
(nconc (cons 'nlist* forms) (list (bq-process lc))))))
|
||||
(T (let ((p x) (q ()))
|
||||
(while (and (consp p)
|
||||
(not (eq (car p) '*comma*)))
|
||||
(set! q (cons (bq-bracket (car p)) q))
|
||||
(set! p (cdr p)))
|
||||
(let ((forms
|
||||
(cond ((consp p) (nreconc q (list (cadr p))))
|
||||
((null p) (nreverse q))
|
||||
(T (nreconc q (list (bq-process p)))))))
|
||||
(if (null (cdr forms))
|
||||
(car forms)
|
||||
(cons 'nconc forms)))))))
|
||||
(#t (let ((p x) (q ()))
|
||||
(while (and (pair? p)
|
||||
(not (eq (car p) '*comma*)))
|
||||
(set! q (cons (bq-bracket (car p)) q))
|
||||
(set! p (cdr p)))
|
||||
(let ((forms
|
||||
(cond ((pair? p) (nreconc q (list (cadr p))))
|
||||
((null? p) (nreverse q))
|
||||
(#t (nreconc q (list (bq-process p)))))))
|
||||
(if (null? (cdr forms))
|
||||
(car forms)
|
||||
(cons 'nconc forms)))))))
|
||||
|
||||
(define (bq-bracket x)
|
||||
(cond ((atom x) (list list (bq-process x)))
|
||||
(cond ((atom? x) (list list (bq-process x)))
|
||||
((eq (car x) '*comma*) (list list (cadr x)))
|
||||
((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
|
||||
((eq (car x) '*comma-dot*) (cadr x))
|
||||
(T (list list (bq-process x)))))
|
||||
(#t (list list (bq-process x)))))
|
||||
|
||||
; bracket without splicing
|
||||
(define (bq-bracket1 x)
|
||||
(if (and (consp x) (eq (car x) '*comma*))
|
||||
(if (and (pair? x) (eq (car x) '*comma*))
|
||||
(cadr x)
|
||||
(bq-process x)))
|
||||
|
||||
(define-macro (assert expr) `(if ,expr T (raise '(assert-failed ,expr))))
|
||||
(define-macro (assert expr) `(if ,expr #t (raise '(assert-failed ,expr))))
|
||||
|
||||
(define-macro (time expr)
|
||||
(let ((t0 (gensym)))
|
||||
|
|
@ -504,14 +496,16 @@
|
|||
,expr
|
||||
(princ "Elapsed time: " (- (time.now) ,t0) " seconds\n")))))
|
||||
|
||||
(define (display x) (princ x) (princ "\n"))
|
||||
(define (display x) (princ x) #t)
|
||||
|
||||
(define (vu8 . elts) (apply array (cons 'uint8 elts)))
|
||||
|
||||
(define (vector.map f v)
|
||||
(let* ((n (length v))
|
||||
(nv (vector.alloc n)))
|
||||
(for 0 (- n 1)
|
||||
(lambda (i)
|
||||
(aset nv i (f (aref v i)))))
|
||||
(aset! nv i (f (aref v i)))))
|
||||
nv))
|
||||
|
||||
(define (table.pairs t)
|
||||
|
|
@ -525,6 +519,6 @@
|
|||
() t))
|
||||
(define (table.clone t)
|
||||
(let ((nt (table)))
|
||||
(table.foldl (lambda (k v z) (put nt k v))
|
||||
(table.foldl (lambda (k v z) (put! nt k v))
|
||||
() t)
|
||||
nt))
|
||||
|
|
|
|||
|
|
@ -103,11 +103,11 @@ value_t fl_table(value_t *args, uint32_t nargs)
|
|||
return nt;
|
||||
}
|
||||
|
||||
// (put table key value)
|
||||
// (put! table key value)
|
||||
value_t fl_table_put(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("put", nargs, 3);
|
||||
htable_t *h = totable(args[0], "put");
|
||||
argcount("put!", nargs, 3);
|
||||
htable_t *h = totable(args[0], "put!");
|
||||
void **table0 = h->table;
|
||||
equalhash_put(h, (void*)args[1], (void*)args[2]);
|
||||
// register finalizer if we outgrew inline space
|
||||
|
|
@ -142,13 +142,13 @@ value_t fl_table_has(value_t *args, uint32_t nargs)
|
|||
return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
// (del table key)
|
||||
// (del! table key)
|
||||
value_t fl_table_del(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("del", nargs, 2);
|
||||
htable_t *h = totable(args[0], "del");
|
||||
argcount("del!", nargs, 2);
|
||||
htable_t *h = totable(args[0], "del!");
|
||||
if (!equalhash_remove(h, (void*)args[1]))
|
||||
lerror(KeyError, "del: key not found");
|
||||
lerror(KeyError, "del!: key not found");
|
||||
return args[0];
|
||||
}
|
||||
|
||||
|
|
@ -178,10 +178,10 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs)
|
|||
static builtinspec_t tablefunc_info[] = {
|
||||
{ "table", fl_table },
|
||||
{ "table?", fl_tablep },
|
||||
{ "put", fl_table_put },
|
||||
{ "put!", fl_table_put },
|
||||
{ "get", fl_table_get },
|
||||
{ "has", fl_table_has },
|
||||
{ "del", fl_table_del },
|
||||
{ "del!", fl_table_del },
|
||||
{ "table.foldl", fl_table_foldl },
|
||||
{ NULL, NULL }
|
||||
};
|
||||
|
|
|
|||
|
|
@ -9,20 +9,20 @@
|
|||
|
||||
;(define (reverse lst)
|
||||
; ((label rev-help (lambda (lst result)
|
||||
; (if (null lst) result
|
||||
; (if (null? lst) result
|
||||
; (rev-help (cdr lst) (cons (car lst) result)))))
|
||||
; lst ()))
|
||||
|
||||
(define (append- . lsts)
|
||||
((label append-h
|
||||
(lambda (lsts)
|
||||
(cond ((null lsts) ())
|
||||
((null (cdr lsts)) (car lsts))
|
||||
(T ((label append2 (lambda (l d)
|
||||
(if (null l) d
|
||||
(cons (car l)
|
||||
(append2 (cdr l) d)))))
|
||||
(car lsts) (append-h (cdr lsts)))))))
|
||||
(cond ((null? lsts) ())
|
||||
((null? (cdr lsts)) (car lsts))
|
||||
(#t ((label append2 (lambda (l d)
|
||||
(if (null? l) d
|
||||
(cons (car l)
|
||||
(append2 (cdr l) d)))))
|
||||
(car lsts) (append-h (cdr lsts)))))))
|
||||
lsts))
|
||||
|
||||
;(princ 'Hello '| | 'world! "\n")
|
||||
|
|
@ -38,13 +38,13 @@
|
|||
; iterative filter
|
||||
(define (ifilter pred lst)
|
||||
((label f (lambda (accum lst)
|
||||
(cond ((null lst) (nreverse accum))
|
||||
(cond ((null? lst) (nreverse accum))
|
||||
((not (pred (car lst))) (f accum (cdr lst)))
|
||||
(T (f (cons (car lst) accum) (cdr lst))))))
|
||||
(#t (f (cons (car lst) accum) (cdr lst))))))
|
||||
() lst))
|
||||
|
||||
(define (sort l)
|
||||
(if (or (null l) (null (cdr l))) l
|
||||
(if (or (null? l) (null? (cdr l))) l
|
||||
(let* ((piv (car l))
|
||||
(halves (separate (lambda (x) (< x piv)) (cdr l))))
|
||||
(nconc (sort (car halves))
|
||||
|
|
@ -81,13 +81,13 @@
|
|||
(cond ((= p 0) 1)
|
||||
((= b 0) 0)
|
||||
((evenp p) (square (expt b (/ p 2))))
|
||||
(T (* b (expt b (- p 1))))))
|
||||
(#t (* b (expt b (- p 1))))))
|
||||
|
||||
(define (gcd a b)
|
||||
(cond ((= a 0) b)
|
||||
((= b 0) a)
|
||||
((< a b) (gcd a (- b a)))
|
||||
(T (gcd b (- a b)))))
|
||||
(#t (gcd b (- a b)))))
|
||||
|
||||
; like eval-when-compile
|
||||
(define-macro (literal expr)
|
||||
|
|
@ -95,7 +95,7 @@
|
|||
(if (self-evaluating? v) v (list quote v))))
|
||||
|
||||
(define (cardepth l)
|
||||
(if (atom l) 0
|
||||
(if (atom? l) 0
|
||||
(+ 1 (cardepth (car l)))))
|
||||
|
||||
(define (nestlist f zero n)
|
||||
|
|
@ -105,7 +105,7 @@
|
|||
(define (mapl f . lsts)
|
||||
((label mapl-
|
||||
(lambda (lsts)
|
||||
(if (null (car lsts)) ()
|
||||
(if (null? (car lsts)) ()
|
||||
(begin (apply f lsts) (mapl- (map cdr lsts))))))
|
||||
lsts))
|
||||
|
||||
|
|
@ -115,7 +115,7 @@
|
|||
|
||||
; swap the cars and cdrs of every cons in a structure
|
||||
(define (swapad c)
|
||||
(if (atom c) c
|
||||
(if (atom? c) c
|
||||
(rplacd c (K (swapad (car c))
|
||||
(rplaca c (swapad (cdr c)))))))
|
||||
|
||||
|
|
@ -123,7 +123,7 @@
|
|||
(filter (lambda (e) (not (eq e x))) l))
|
||||
|
||||
(define (conscount c)
|
||||
(if (consp c) (+ 1
|
||||
(if (pair? c) (+ 1
|
||||
(conscount (car c))
|
||||
(conscount (cdr c)))
|
||||
0))
|
||||
|
|
@ -163,7 +163,7 @@
|
|||
(todo (f-body (cddr catc))))
|
||||
`(lambda (,var)
|
||||
(if (or (eq ,var ',extype)
|
||||
(and (consp ,var)
|
||||
(and (pair? ,var)
|
||||
(eq (car ,var) ',extype)))
|
||||
,todo
|
||||
(,next ,var)))))
|
||||
|
|
@ -220,8 +220,8 @@
|
|||
(cdr ,first))))
|
||||
|
||||
(define (map-indexed f lst)
|
||||
(if (atom lst) lst
|
||||
(if (atom? lst) lst
|
||||
(let ((i 0))
|
||||
(accumulate-while (consp lst) (f (car lst) i)
|
||||
(accumulate-while (pair? lst) (f (car lst) i)
|
||||
(begin (set! lst (cdr lst))
|
||||
(set! i (1+ i)))))))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
; -*- scheme -*-
|
||||
(define (maplist f l)
|
||||
(if (null l) ()
|
||||
(if (null? l) ()
|
||||
(cons (f l) (maplist f (cdr l)))))
|
||||
|
||||
; produce a beautiful, toroidal cons structure
|
||||
|
|
|
|||
|
|
@ -7,9 +7,9 @@
|
|||
(list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
|
||||
|
||||
(define (each f l)
|
||||
(if (atom l) ()
|
||||
(begin (f (car l))
|
||||
(each f (cdr l)))))
|
||||
(if (atom? l) ()
|
||||
(begin (f (car l))
|
||||
(each f (cdr l)))))
|
||||
|
||||
(define (each^2 f l m)
|
||||
(each (lambda (o) (each (lambda (p) (f o p)) m)) l))
|
||||
|
|
@ -82,4 +82,4 @@
|
|||
(3 . d) (2 . c) (0 . b) (1 . a))))
|
||||
|
||||
(princ "all tests pass\n")
|
||||
T
|
||||
#t
|
||||
|
|
|
|||
Loading…
Reference in New Issue