switching to scheme #t, #f, and () values
porting code to sort out which NILs are false and which are empty lists switching to scheme-style special forms. however you feel about scheme names vs. CL names, using both is silly. mostly switching to scheme predicate names, with compatibility aliases for now. adding set-constant! to make this efficient. adding null?, eqv?, assq, assv, assoc, memq, memv, member adding 2-argument form of if allowing else as final cond condition looking for init file in same directory as executable, so flisp can be started from anywhere renaming T to FL_T, since exporting a 1-character symbol is not very nice adding opaque type boilerplate example file adding correctness checking for the pattern-lambda benchmark bugfix in int2str
This commit is contained in:
JeffBezanson
parent
38cf75733e
commit
a55b46e9a6
|
|
@ -1,3 +1,4 @@
|
|||
; -*- scheme -*-
|
||||
; utilities for AST processing
|
||||
|
||||
(define (symconcat s1 s2)
|
||||
|
|
@ -9,13 +10,13 @@
|
|||
(cons item lst)))
|
||||
|
||||
(define (index-of item lst start)
|
||||
(cond ((null lst) nil)
|
||||
(cond ((null lst) #f)
|
||||
((eq item (car lst)) start)
|
||||
(T (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (each f l)
|
||||
(if (null l) l
|
||||
(progn (f (car l))
|
||||
(begin (f (car l))
|
||||
(each f (cdr l)))))
|
||||
|
||||
(define (maptree-pre f tr)
|
||||
|
|
@ -136,19 +137,19 @@
|
|||
env))))
|
||||
|
||||
; flatten op with any associativity
|
||||
(defmacro flatten-all-op (op e)
|
||||
(define-macro (flatten-all-op op e)
|
||||
`(pattern-expand
|
||||
(pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
|
||||
(cons ',op (append l (cdr inner) r)))
|
||||
,e))
|
||||
|
||||
(defmacro pattern-lambda (pat body)
|
||||
(define-macro (pattern-lambda pat body)
|
||||
(let* ((args (patargs pat))
|
||||
(expander `(lambda ,args ,body)))
|
||||
`(lambda (expr)
|
||||
(let ((m (match ',pat expr)))
|
||||
(if m
|
||||
; matches; perform expansion
|
||||
(apply ,expander (map (lambda (var) (cdr (or (assoc var m) '(0 . nil))))
|
||||
(apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
|
||||
',args))
|
||||
nil)))))
|
||||
#f)))))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
; -*- scheme -*-
|
||||
; tree regular expression pattern matching
|
||||
; by Jeff Bezanson
|
||||
|
||||
|
|
@ -41,12 +42,12 @@
|
|||
(cond ((symbolp p)
|
||||
(cond ((eq p '_) state)
|
||||
(T
|
||||
(let ((capt (assoc p state)))
|
||||
(let ((capt (assq p state)))
|
||||
(if capt
|
||||
(and (equal expr (cdr capt)) state)
|
||||
(cons (cons p expr) state))))))
|
||||
|
||||
((functionp p)
|
||||
((function? p)
|
||||
(and (p expr) state))
|
||||
|
||||
((consp p)
|
||||
|
|
@ -56,7 +57,7 @@
|
|||
(and (match- (caddr p) expr state)
|
||||
(cons (cons (cadr p) expr) state)))
|
||||
((eq (car p) '-$) ; greedy alternation for toplevel pattern
|
||||
(match-alt (cdr p) () (list expr) state nil 1))
|
||||
(match-alt (cdr p) () (list expr) state #f 1))
|
||||
(T
|
||||
(and (consp expr)
|
||||
(equal (car p) (car expr))
|
||||
|
|
@ -67,7 +68,7 @@
|
|||
|
||||
; match an alternation
|
||||
(define (match-alt alt prest expr state var L)
|
||||
(if (null alt) nil ; no alternatives left
|
||||
(if (null alt) #f ; no alternatives left
|
||||
(let ((subma (match- (car alt) (car expr) state)))
|
||||
(or (and subma
|
||||
(match-seq prest (cdr expr)
|
||||
|
|
@ -81,7 +82,7 @@
|
|||
; 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) nil)
|
||||
((> min max) #f)
|
||||
; case 1: only allowed to match 0 subexpressions
|
||||
((= max 0) (match-seq prest expr
|
||||
(if var (cons (cons var (reverse sofar)) state)
|
||||
|
|
@ -101,16 +102,16 @@
|
|||
|
||||
; match sequences of expressions
|
||||
(define (match-seq p expr state L)
|
||||
(cond ((not state) nil)
|
||||
((null p) (if (null expr) state nil))
|
||||
(cond ((not state) #f)
|
||||
((null p) (if (null expr) state #f))
|
||||
(T
|
||||
(let ((subp (car p))
|
||||
(var nil))
|
||||
(var #f))
|
||||
(if (and (consp subp)
|
||||
(eq (car subp) '--))
|
||||
(progn (setq var (cadr subp))
|
||||
(setq subp (caddr subp)))
|
||||
nil)
|
||||
(begin (set! var (cadr subp))
|
||||
(set! subp (caddr subp)))
|
||||
#f)
|
||||
(let ((head (if (consp subp) (car subp) ())))
|
||||
(cond ((eq subp '...)
|
||||
(match-star '_ (cdr p) expr state var 0 L L))
|
||||
|
|
@ -149,7 +150,7 @@
|
|||
; returns the new expression, or expr if no matches
|
||||
(define (apply-patterns plist expr)
|
||||
(if (null plist) expr
|
||||
(if (functionp plist)
|
||||
(if (function? plist)
|
||||
(let ((enew (plist expr)))
|
||||
(if (not enew)
|
||||
expr
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,3 +1,4 @@
|
|||
; -*- scheme -*-
|
||||
(load "match.lsp")
|
||||
(load "asttools.lsp")
|
||||
|
||||
|
|
@ -18,10 +19,14 @@
|
|||
|
||||
; transformations
|
||||
|
||||
(let ((ctr 0))
|
||||
(define (r-gensym) (prog1 (intern (string "%r:" ctr))
|
||||
(set! ctr (+ ctr 1)))))
|
||||
|
||||
(define (dollarsign-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda ($ lhs name)
|
||||
(let* ((g (if (not (consp lhs)) lhs (gensym)))
|
||||
(let* ((g (if (not (consp lhs)) lhs (r-gensym)))
|
||||
(n (if (symbolp name)
|
||||
name ;(symbol->string name)
|
||||
name))
|
||||
|
|
@ -41,7 +46,7 @@
|
|||
(pattern-expand
|
||||
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
|
||||
(<<- (r-call f lhs ...) rhs))
|
||||
(let ((g (if (consp rhs) (gensym) rhs))
|
||||
(let ((g (if (consp rhs) (r-gensym) rhs))
|
||||
(op (car __)))
|
||||
`(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
|
||||
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
|
||||
|
|
@ -77,9 +82,9 @@
|
|||
(let ((vars ()))
|
||||
(maptree-pre (lambda (s)
|
||||
(if (not (consp s)) s
|
||||
(cond ((eq (car s) 'lambda) nil)
|
||||
(cond ((eq (car s) 'lambda) ())
|
||||
((eq (car s) '<-)
|
||||
(setq vars (list-adjoin (cadr s) vars))
|
||||
(set! vars (list-adjoin (cadr s) vars))
|
||||
(cddr s))
|
||||
(T s))))
|
||||
n)
|
||||
|
|
@ -102,18 +107,3 @@
|
|||
(fancy-assignment-transform
|
||||
(dollarsign-transform
|
||||
(flatten-all-op && (flatten-all-op \|\| e)))))))
|
||||
|
||||
;(trace map)
|
||||
;(pretty-print (compile-ish *input*))
|
||||
;(print
|
||||
; (time-call (lambda () (compile-ish *input*)) 1)
|
||||
;)
|
||||
(define (main)
|
||||
(progn
|
||||
(define *input* (load "datetimeR.lsp"))
|
||||
;(define t0 ((java.util.Date:new):getTime))
|
||||
(time (compile-ish *input*))
|
||||
;(define t1 ((java.util.Date:new):getTime))
|
||||
))
|
||||
|
||||
(main)
|
||||
|
|
|
|||
|
|
@ -81,21 +81,32 @@ value_t fl_intern(value_t *args, u_int32_t nargs)
|
|||
return symbol(cvalue_data(args[0]));
|
||||
}
|
||||
|
||||
value_t fl_setconstant(value_t *args, u_int32_t nargs)
|
||||
{
|
||||
argcount("set-constant!", nargs, 2);
|
||||
symbol_t *sym = tosymbol(args[0], "set-constant!");
|
||||
if (isconstant(args[0]) || sym->binding != UNBOUND)
|
||||
lerror(ArgError, "set-constant!: cannot redefine %s",
|
||||
symbol_name(args[0]));
|
||||
setc(args[0], args[1]);
|
||||
return args[1];
|
||||
}
|
||||
|
||||
extern value_t LAMBDA;
|
||||
|
||||
value_t fl_setsyntax(value_t *args, u_int32_t nargs)
|
||||
{
|
||||
argcount("set-syntax", nargs, 2);
|
||||
symbol_t *sym = tosymbol(args[0], "set-syntax");
|
||||
argcount("set-syntax!", nargs, 2);
|
||||
symbol_t *sym = tosymbol(args[0], "set-syntax!");
|
||||
if (sym->syntax && (sym->syntax == TAG_CONST || isspecial(sym->syntax)))
|
||||
lerror(ArgError, "set-syntax: cannot define syntax for %s",
|
||||
lerror(ArgError, "set-syntax!: cannot define syntax for %s",
|
||||
symbol_name(args[0]));
|
||||
if (args[1] == NIL) {
|
||||
if (args[1] == FL_F) {
|
||||
sym->syntax = 0;
|
||||
}
|
||||
else {
|
||||
if (!iscons(args[1]) || car_(args[1])!=LAMBDA)
|
||||
type_error("set-syntax", "function", args[1]);
|
||||
type_error("set-syntax!", "function", args[1]);
|
||||
sym->syntax = args[1];
|
||||
}
|
||||
return args[1];
|
||||
|
|
@ -109,7 +120,7 @@ value_t fl_symbolsyntax(value_t *args, u_int32_t nargs)
|
|||
// don't behave like functions (they take their arguments directly
|
||||
// from the form rather than from the stack of evaluated arguments)
|
||||
if (sym->syntax == TAG_CONST || isspecial(sym->syntax))
|
||||
return NIL;
|
||||
return FL_F;
|
||||
return sym->syntax;
|
||||
}
|
||||
|
||||
|
|
@ -160,15 +171,15 @@ extern value_t QUOTE;
|
|||
|
||||
value_t fl_constantp(value_t *args, u_int32_t nargs)
|
||||
{
|
||||
argcount("constantp", nargs, 1);
|
||||
argcount("constant?", nargs, 1);
|
||||
if (issymbol(args[0]))
|
||||
return (isconstant(args[0]) ? T : NIL);
|
||||
return (isconstant(args[0]) ? FL_T : FL_F);
|
||||
if (iscons(args[0])) {
|
||||
if (car_(args[0]) == QUOTE)
|
||||
return T;
|
||||
return NIL;
|
||||
return FL_T;
|
||||
return FL_F;
|
||||
}
|
||||
return T;
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
value_t fl_fixnum(value_t *args, u_int32_t nargs)
|
||||
|
|
@ -278,7 +289,7 @@ value_t fl_path_cwd(value_t *args, uint32_t nargs)
|
|||
char *ptr = tostring(args[0], "path.cwd");
|
||||
if (set_cwd(ptr))
|
||||
lerror(IOError, "could not cd to %s", ptr);
|
||||
return T;
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
value_t fl_os_getenv(value_t *args, uint32_t nargs)
|
||||
|
|
@ -286,7 +297,7 @@ value_t fl_os_getenv(value_t *args, uint32_t nargs)
|
|||
argcount("os.getenv", nargs, 1);
|
||||
char *name = tostring(args[0], "os.getenv");
|
||||
char *val = getenv(name);
|
||||
if (val == NULL) return NIL;
|
||||
if (val == NULL) return FL_F;
|
||||
if (*val == 0)
|
||||
return symbol_value(emptystringsym);
|
||||
return cvalue_static_cstring(val);
|
||||
|
|
@ -297,7 +308,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
|
|||
argcount("os.setenv", nargs, 2);
|
||||
char *name = tostring(args[0], "os.setenv");
|
||||
int result;
|
||||
if (args[1] == NIL) {
|
||||
if (args[1] == FL_F) {
|
||||
result = unsetenv(name);
|
||||
}
|
||||
else {
|
||||
|
|
@ -306,7 +317,7 @@ value_t fl_os_setenv(value_t *args, uint32_t nargs)
|
|||
}
|
||||
if (result != 0)
|
||||
lerror(ArgError, "os.setenv: invalid environment variable");
|
||||
return T;
|
||||
return FL_T;
|
||||
}
|
||||
|
||||
value_t fl_rand(value_t *args, u_int32_t nargs)
|
||||
|
|
@ -351,11 +362,12 @@ extern void stringfuncs_init();
|
|||
extern void table_init();
|
||||
|
||||
static builtinspec_t builtin_info[] = {
|
||||
{ "set-syntax", fl_setsyntax },
|
||||
{ "set-constant!", fl_setconstant },
|
||||
{ "set-syntax!", fl_setsyntax },
|
||||
{ "symbol-syntax", fl_symbolsyntax },
|
||||
{ "syntax-environment", fl_syntax_env },
|
||||
{ "environment", fl_global_env },
|
||||
{ "constantp", fl_constantp },
|
||||
{ "constant?", fl_constantp },
|
||||
|
||||
{ "print", fl_print },
|
||||
{ "princ", fl_princ },
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
; -*- scheme -*-
|
||||
; uncomment for compatibility with CL
|
||||
;(defun mapp (f l) (mapcar f l))
|
||||
;(defmacro define (name &rest body)
|
||||
|
|
@ -18,7 +19,7 @@
|
|||
((equal key (caar dl)) (cdar dl))
|
||||
(T (dict-lookup (cdr dl) key))))
|
||||
|
||||
(define (dict-keys dl) (map (symbol-function 'car) dl))
|
||||
(define (dict-keys dl) (map car dl))
|
||||
|
||||
; graphs ----------------------------------------------------------------------
|
||||
(define (graph-empty) (dict-new))
|
||||
|
|
@ -50,14 +51,14 @@
|
|||
color-of-node
|
||||
(map
|
||||
(lambda (n)
|
||||
(let ((color-pair (assoc n coloring)))
|
||||
(if (consp color-pair) (cdr color-pair) nil)))
|
||||
(let ((color-pair (assq n coloring)))
|
||||
(if (consp color-pair) (cdr color-pair) ())))
|
||||
(graph-neighbors g node-to-color)))))
|
||||
|
||||
(define (try-each f lst)
|
||||
(if (null lst) nil
|
||||
(let ((ret (funcall f (car lst))))
|
||||
(if ret ret (try-each f (cdr lst))))))
|
||||
(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
|
||||
|
|
@ -71,24 +72,24 @@
|
|||
|
||||
(define (color-graph g colors)
|
||||
(if (null colors)
|
||||
(null (graph-nodes g))
|
||||
(color-node g () colors (graph-nodes g) (car colors))))
|
||||
(and (null (graph-nodes g)) ())
|
||||
(color-node g () colors (graph-nodes g) (car colors))))
|
||||
|
||||
(define (color-pairs pairs colors)
|
||||
(color-graph (graph-from-edges pairs) colors))
|
||||
|
||||
; queens ----------------------------------------------------------------------
|
||||
(defun can-attack (x y)
|
||||
(define (can-attack x y)
|
||||
(let ((x1 (mod x 5))
|
||||
(y1 (truncate (/ x 5)))
|
||||
(x2 (mod y 5))
|
||||
(y2 (truncate (/ y 5))))
|
||||
(or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
|
||||
|
||||
(defun generate-5x5-pairs ()
|
||||
(let ((result nil))
|
||||
(define (generate-5x5-pairs)
|
||||
(let ((result ()))
|
||||
(dotimes (x 25)
|
||||
(dotimes (y 25)
|
||||
(if (and (/= x y) (can-attack x y))
|
||||
(setq result (cons (cons x y) result)) nil)))
|
||||
(set! result (cons (cons x y) result)) ())))
|
||||
result))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
; -*- scheme -*-
|
||||
(define (cond->if form)
|
||||
(cond-clauses->if (cdr form)))
|
||||
(define (cond-clauses->if lst)
|
||||
|
|
@ -8,30 +9,30 @@
|
|||
,(f-body (cdr clause))
|
||||
,(cond-clauses->if (cdr lst))))))
|
||||
|
||||
(define (progn->cps forms k)
|
||||
(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 (,_)
|
||||
,(progn->cps (cdr forms) k)))))))
|
||||
,(begin->cps (cdr forms) k)))))))
|
||||
|
||||
(defmacro lambda/cc (args body)
|
||||
(define-macro (lambda/cc args body)
|
||||
`(rplaca (lambda ,args ,body) 'lambda/cc))
|
||||
|
||||
; a utility used at run time to dispatch a call with or without
|
||||
; the continuation argument, depending on the function
|
||||
(define (funcall/cc f k . args)
|
||||
(if (and (consp f) (eq (car f) 'lambda/cc))
|
||||
(if (and (pair? f) (eq (car f) 'lambda/cc))
|
||||
(apply f (cons k args))
|
||||
(k (apply f args))))
|
||||
(define *funcall/cc-names*
|
||||
(list-to-vector
|
||||
(map (lambda (i) (intern (string 'funcall/cc- i)))
|
||||
(iota 6))))
|
||||
(defmacro def-funcall/cc-n (args)
|
||||
(define-macro (def-funcall/cc-n args)
|
||||
(let* ((name (aref *funcall/cc-names* (length args))))
|
||||
`(define (,name f k ,@args)
|
||||
(if (and (consp f) (eq (car f) 'lambda/cc))
|
||||
(if (and (pair? f) (eq (car f) 'lambda/cc))
|
||||
(f k ,@args)
|
||||
(k (f ,@args))))))
|
||||
(def-funcall/cc-n ())
|
||||
|
|
@ -43,7 +44,7 @@
|
|||
|
||||
(define (rest->cps xformer form k argsyms)
|
||||
(let ((el (car form)))
|
||||
(if (or (atom el) (constantp el))
|
||||
(if (or (atom el) (constant? el))
|
||||
(xformer (cdr form) k (cons el argsyms))
|
||||
(let ((g (gensym)))
|
||||
(cps- el `(lambda (,g)
|
||||
|
|
@ -79,14 +80,14 @@
|
|||
(cps- (macroexpand form) *top-k*)))))
|
||||
(define (cps- form k)
|
||||
(let ((g (gensym)))
|
||||
(cond ((or (atom form) (constantp form))
|
||||
(cond ((or (atom form) (constant? form))
|
||||
`(,k ,form))
|
||||
|
||||
((eq (car form) 'lambda)
|
||||
`(,k (lambda/cc ,(cons g (cadr form)) ,(cps- (caddr form) g))))
|
||||
|
||||
((eq (car form) 'progn)
|
||||
(progn->cps (cdr form) k))
|
||||
((eq (car form) 'begin)
|
||||
(begin->cps (cdr form) k))
|
||||
|
||||
((eq (car form) 'cond)
|
||||
(cps- (cond->if form) k))
|
||||
|
|
@ -116,7 +117,7 @@
|
|||
,(cps- form g))))))
|
||||
|
||||
((eq (car form) 'or)
|
||||
(cond ((atom (cdr form)) `(,k ()))
|
||||
(cond ((atom (cdr form)) `(,k #f))
|
||||
((atom (cddr form)) (cps- (cadr form) k))
|
||||
(T
|
||||
(if (atom k)
|
||||
|
|
@ -132,18 +133,18 @@
|
|||
(body (caddr form))
|
||||
(lastval (gensym)))
|
||||
(cps- (macroexpand
|
||||
`(let ((,lastval nil))
|
||||
`(let ((,lastval #f))
|
||||
((label ,g (lambda ()
|
||||
(if ,test
|
||||
(progn (setq ,lastval ,body)
|
||||
(begin (set! ,lastval ,body)
|
||||
(,g))
|
||||
,lastval))))))
|
||||
k)))
|
||||
|
||||
((eq (car form) 'setq)
|
||||
((eq (car form) 'set!)
|
||||
(let ((var (cadr form))
|
||||
(E (caddr form)))
|
||||
(cps- E `(lambda (,g) (,k (setq ,var ,g))))))
|
||||
(cps- E `(lambda (,g) (,k (set! ,var ,g))))))
|
||||
|
||||
((eq (car form) 'reset)
|
||||
`(,k ,(cps- (cadr form) *top-k*)))
|
||||
|
|
@ -158,12 +159,12 @@
|
|||
((eq (car form) 'without-delimited-continuations)
|
||||
`(,k ,(cadr form)))
|
||||
|
||||
((and (constantp (car form))
|
||||
(builtinp (eval (car form))))
|
||||
((and (constant? (car form))
|
||||
(builtin? (eval (car form))))
|
||||
(builtincall->cps form k))
|
||||
|
||||
; ((lambda (...) body) ...)
|
||||
((and (consp (car form))
|
||||
((and (pair? (car form))
|
||||
(eq (caar form) 'lambda))
|
||||
(let ((largs (cadr (car form)))
|
||||
(lbody (caddr (car form))))
|
||||
|
|
@ -183,13 +184,13 @@
|
|||
; (lambda (args...) (f args...)) => f
|
||||
; but only for constant, builtin f
|
||||
(define (η-reduce form)
|
||||
(cond ((or (atom form) (constantp form)) form)
|
||||
(cond ((or (atom form) (constant? form)) form)
|
||||
((and (eq (car form) 'lambda)
|
||||
(let ((body (caddr form))
|
||||
(args (cadr form)))
|
||||
(and (consp body)
|
||||
(and (pair? body)
|
||||
(equal (cdr body) args)
|
||||
(constantp (car (caddr form))))))
|
||||
(constant? (car (caddr form))))))
|
||||
(car (caddr form)))
|
||||
(T (map η-reduce form))))
|
||||
|
||||
|
|
@ -198,18 +199,18 @@
|
|||
(any (lambda (p) (contains x p)) form)))
|
||||
|
||||
(define (β-reduce form)
|
||||
(if (or (atom form) (constantp form))
|
||||
(if (or (atom form) (constant? form))
|
||||
form
|
||||
(β-reduce- (map β-reduce form))))
|
||||
|
||||
(define (β-reduce- form)
|
||||
; ((lambda (f) (f arg)) X) => (X arg)
|
||||
(cond ((and (= (length form) 2)
|
||||
(consp (car form))
|
||||
(pair? (car form))
|
||||
(eq (caar form) 'lambda)
|
||||
(let ((args (cadr (car form)))
|
||||
(body (caddr (car form))))
|
||||
(and (consp body) (consp args)
|
||||
(and (pair? body) (pair? args)
|
||||
(= (length body) 2)
|
||||
(= (length args) 1)
|
||||
(eq (car body) (car args))
|
||||
|
|
@ -227,15 +228,15 @@
|
|||
; ((lambda (p1 args...) body) s exprs...)
|
||||
; where exprs... doesn't contain p1
|
||||
((and (= (length form) 2)
|
||||
(consp (car form))
|
||||
(pair? (car form))
|
||||
(eq (caar form) 'lambda)
|
||||
(or (atom (cadr form)) (constantp (cadr form)))
|
||||
(or (atom (cadr form)) (constant? (cadr form)))
|
||||
(let ((args (cadr (car form)))
|
||||
(s (cadr form))
|
||||
(body (caddr (car form))))
|
||||
(and (consp args) (= (length args) 1)
|
||||
(consp body)
|
||||
(consp (car body))
|
||||
(and (pair? args) (= (length args) 1)
|
||||
(pair? body)
|
||||
(pair? (car body))
|
||||
(eq (caar body) 'lambda)
|
||||
(let ((innerargs (cadr (car body)))
|
||||
(innerbody (caddr (car body)))
|
||||
|
|
@ -248,14 +249,17 @@
|
|||
|
||||
(T form)))
|
||||
|
||||
(defmacro with-delimited-continuations code (cps (f-body code)))
|
||||
(define-macro (with-delimited-continuations . code)
|
||||
(cps (f-body code)))
|
||||
|
||||
(defmacro defgenerator (name args . body)
|
||||
(define-macro (define-generator form . body)
|
||||
(let ((ko (gensym))
|
||||
(cur (gensym)))
|
||||
`(defun ,name ,args
|
||||
(let ((,ko ())
|
||||
(,cur ()))
|
||||
(cur (gensym))
|
||||
(name (car form))
|
||||
(args (cdr form)))
|
||||
`(define (,name ,@args)
|
||||
(let ((,ko #f)
|
||||
(,cur #f))
|
||||
(lambda ()
|
||||
(with-delimited-continuations
|
||||
(if ,ko (,ko ,cur)
|
||||
|
|
@ -263,17 +267,17 @@
|
|||
(let ((yield
|
||||
(lambda (v)
|
||||
(shift yk
|
||||
(progn (setq ,ko yk)
|
||||
(setq ,cur v))))))
|
||||
(begin (set! ,ko yk)
|
||||
(set! ,cur v))))))
|
||||
,(f-body body))))))))))
|
||||
|
||||
; a test case
|
||||
(defgenerator range-iterator (lo hi)
|
||||
(define-generator (range-iterator lo hi)
|
||||
((label loop
|
||||
(lambda (i)
|
||||
(if (< hi i)
|
||||
'done
|
||||
(progn (yield i)
|
||||
(begin (yield i)
|
||||
(loop (+ 1 i))))))
|
||||
lo))
|
||||
|
||||
|
|
@ -301,15 +305,15 @@ todo:
|
|||
|
||||
(let ((x 0))
|
||||
(while (< x 10)
|
||||
(progn (print x) (setq x (+ 1 x)))))
|
||||
(begin (print x) (set! x (+ 1 x)))))
|
||||
=>
|
||||
(let ((x 0))
|
||||
(reset
|
||||
(let ((l nil))
|
||||
(let ((l #f))
|
||||
(let ((k (shift k (k k))))
|
||||
(if (< x 10)
|
||||
(progn (setq l (progn (print x)
|
||||
(setq x (+ 1 x))))
|
||||
(begin (set! l (begin (print x)
|
||||
(set! x (+ 1 x))))
|
||||
(k k))
|
||||
l)))))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -617,7 +617,12 @@ value_t cvalue_typeof(value_t *args, u_int32_t nargs)
|
|||
case TAG_NUM: return fixnumsym;
|
||||
case TAG_SYM: return symbolsym;
|
||||
case TAG_VECTOR: return vectorsym;
|
||||
case TAG_BUILTIN: return builtinsym;
|
||||
case TAG_BUILTIN:
|
||||
if (args[0] == FL_T || args[0] == FL_F)
|
||||
return booleansym;
|
||||
if (args[0] == NIL)
|
||||
return nullsym;
|
||||
return builtinsym;
|
||||
}
|
||||
return cv_type((cvalue_t*)ptr(args[0]));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -256,8 +256,8 @@ value_t compare(value_t a, value_t b)
|
|||
value_t equal(value_t a, value_t b)
|
||||
{
|
||||
if (eq_comparable(a, b))
|
||||
return (a == b) ? T : NIL;
|
||||
return (numval(compare_(a,b,1))==0 ? T : NIL);
|
||||
return (a == b) ? FL_T : FL_F;
|
||||
return (numval(compare_(a,b,1))==0 ? FL_T : FL_F);
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@
|
|||
* cvalues system providing C data types and a C FFI
|
||||
* constructor notation for nicely printing arbitrary values
|
||||
* strings
|
||||
- hash tables
|
||||
* hash tables
|
||||
|
||||
by Jeff Bezanson (C) 2009
|
||||
Distributed under the BSD License
|
||||
|
|
@ -52,27 +52,28 @@
|
|||
|
||||
static char *builtin_names[] =
|
||||
{ "quote", "cond", "if", "and", "or", "while", "lambda",
|
||||
"trycatch", "%apply", "setq", "progn",
|
||||
"trycatch", "%apply", "set!", "begin",
|
||||
|
||||
"eq", "atom", "not", "symbolp", "numberp", "boundp", "consp",
|
||||
"builtinp", "vectorp", "fixnump", "equal",
|
||||
"cons", "list", "car", "cdr", "rplaca", "rplacd",
|
||||
"eq?", "eqv?", "equal?", "atom?", "not", "null?", "boolean?", "symbol?",
|
||||
"number?", "bound?", "pair?", "builtin?", "vector?", "fixnum?",
|
||||
|
||||
"cons", "list", "car", "cdr", "set-car!", "set-cdr!",
|
||||
"eval", "eval*", "apply", "prog1", "raise",
|
||||
"+", "-", "*", "/", "<", "~", "&", "!", "$",
|
||||
"vector", "aref", "aset", "length", "assoc", "compare",
|
||||
"for" };
|
||||
"vector", "aref", "aset", "length", "assq", "compare", "for",
|
||||
"", "", "" };
|
||||
|
||||
#define N_STACK 98304
|
||||
value_t Stack[N_STACK];
|
||||
uint32_t SP = 0;
|
||||
|
||||
value_t NIL, T, LAMBDA, QUOTE, IF, TRYCATCH;
|
||||
value_t NIL, FL_T, FL_F, LAMBDA, QUOTE, IF, TRYCATCH;
|
||||
value_t BACKQUOTE, COMMA, COMMAAT, COMMADOT;
|
||||
value_t IOError, ParseError, TypeError, ArgError, UnboundError, MemoryError;
|
||||
value_t DivideError, BoundsError, Error, KeyError;
|
||||
value_t conssym, symbolsym, fixnumsym, vectorsym, builtinsym;
|
||||
value_t defunsym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
|
||||
value_t printwidthsym;
|
||||
value_t definesym, defmacrosym, forsym, labelsym, printprettysym, setqsym;
|
||||
value_t printwidthsym, tsym, Tsym, fsym, Fsym, booleansym, nullsym, elsesym;
|
||||
|
||||
static value_t eval_sexpr(value_t e, uint32_t penv, int tail);
|
||||
static value_t *alloc_words(int n);
|
||||
|
|
@ -592,7 +593,7 @@ int isnumber(value_t v)
|
|||
// eval -----------------------------------------------------------------------
|
||||
|
||||
// return a cons element of v whose car is item
|
||||
static value_t assoc(value_t item, value_t v)
|
||||
static value_t assq(value_t item, value_t v)
|
||||
{
|
||||
value_t bind;
|
||||
|
||||
|
|
@ -602,7 +603,7 @@ static value_t assoc(value_t item, value_t v)
|
|||
return bind;
|
||||
v = cdr_(v);
|
||||
}
|
||||
return NIL;
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
@ -646,7 +647,7 @@ static value_t do_trycatch(value_t expr, uint32_t penv)
|
|||
FL_CATCH {
|
||||
v = cdr_(Stack[SP-1]);
|
||||
if (!iscons(v)) {
|
||||
v = NIL; // 1-argument form
|
||||
v = FL_F; // 1-argument form
|
||||
}
|
||||
else {
|
||||
Stack[SP-1] = car_(v);
|
||||
|
|
@ -771,7 +772,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
if (*pv == NIL) break;
|
||||
pv = &vector_elt(*pv, 0);
|
||||
}
|
||||
sym = tosymbol(e, "setq");
|
||||
sym = tosymbol(e, "set!");
|
||||
if (sym->syntax != TAG_CONST)
|
||||
sym->binding = v;
|
||||
break;
|
||||
|
|
@ -809,24 +810,28 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
case F_IF:
|
||||
if (!iscons(Stack[saveSP])) goto notpair;
|
||||
v = car_(Stack[saveSP]);
|
||||
if (eval(v) != NIL) {
|
||||
if (eval(v) != FL_F) {
|
||||
v = cdr_(Stack[saveSP]);
|
||||
if (!iscons(v)) goto notpair;
|
||||
v = car_(v);
|
||||
}
|
||||
else {
|
||||
v = cdr_(Stack[saveSP]);
|
||||
if (!iscons(v) || !iscons(v=cdr_(v))) goto notpair;
|
||||
v = car_(v);
|
||||
if (!iscons(v)) goto notpair;
|
||||
if (!iscons(v=cdr_(v))) v = FL_F; // allow 2-arg form
|
||||
else v = car_(v);
|
||||
}
|
||||
tail_eval(v);
|
||||
break;
|
||||
case F_COND:
|
||||
pv = &Stack[saveSP]; v = NIL;
|
||||
pv = &Stack[saveSP]; v = FL_F;
|
||||
while (iscons(*pv)) {
|
||||
c = tocons(car_(*pv), "cond");
|
||||
v = eval(c->car);
|
||||
if (v != NIL) {
|
||||
v = c->car;
|
||||
// allow last condition to be 'else'
|
||||
if (iscons(cdr_(*pv)) || v != elsesym)
|
||||
v = eval(v);
|
||||
if (v != FL_F) {
|
||||
*pv = cdr_(car_(*pv));
|
||||
// evaluate body forms
|
||||
if (iscons(*pv)) {
|
||||
|
|
@ -842,11 +847,11 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
break;
|
||||
case F_AND:
|
||||
pv = &Stack[saveSP]; v = T;
|
||||
pv = &Stack[saveSP]; v = FL_T;
|
||||
if (iscons(*pv)) {
|
||||
while (iscons(cdr_(*pv))) {
|
||||
if ((v=eval(car_(*pv))) == NIL) {
|
||||
SP = saveSP; return NIL;
|
||||
if ((v=eval(car_(*pv))) == FL_F) {
|
||||
SP = saveSP; return FL_F;
|
||||
}
|
||||
*pv = cdr_(*pv);
|
||||
}
|
||||
|
|
@ -854,10 +859,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
break;
|
||||
case F_OR:
|
||||
pv = &Stack[saveSP]; v = NIL;
|
||||
pv = &Stack[saveSP]; v = FL_F;
|
||||
if (iscons(*pv)) {
|
||||
while (iscons(cdr_(*pv))) {
|
||||
if ((v=eval(car_(*pv))) != NIL) {
|
||||
if ((v=eval(car_(*pv))) != FL_F) {
|
||||
SP = saveSP; return v;
|
||||
}
|
||||
*pv = cdr_(*pv);
|
||||
|
|
@ -871,9 +876,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
PUSH(*body);
|
||||
Stack[saveSP] = car_(Stack[saveSP]);
|
||||
value_t *cond = &Stack[saveSP];
|
||||
PUSH(NIL);
|
||||
PUSH(FL_F);
|
||||
pv = &Stack[SP-1];
|
||||
while (eval(*cond) != NIL) {
|
||||
while (eval(*cond) != FL_F) {
|
||||
*body = Stack[SP-2];
|
||||
while (iscons(*body)) {
|
||||
*pv = eval(car_(*body));
|
||||
|
|
@ -892,7 +897,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
tail_eval(car_(*pv));
|
||||
}
|
||||
v = NIL;
|
||||
v = FL_F;
|
||||
break;
|
||||
case F_TRYCATCH:
|
||||
v = do_trycatch(car(Stack[saveSP]), penv);
|
||||
|
|
@ -900,13 +905,13 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
|
||||
// ordinary functions
|
||||
case F_BOUNDP:
|
||||
argcount("boundp", nargs, 1);
|
||||
sym = tosymbol(Stack[SP-1], "boundp");
|
||||
v = (sym->binding == UNBOUND) ? NIL : T;
|
||||
argcount("bound?", nargs, 1);
|
||||
sym = tosymbol(Stack[SP-1], "bound?");
|
||||
v = (sym->binding == UNBOUND) ? FL_F : FL_T;
|
||||
break;
|
||||
case F_EQ:
|
||||
argcount("eq", nargs, 2);
|
||||
v = ((Stack[SP-2] == Stack[SP-1]) ? T : NIL);
|
||||
argcount("eq?", nargs, 2);
|
||||
v = ((Stack[SP-2] == Stack[SP-1]) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_CONS:
|
||||
argcount("cons", nargs, 2);
|
||||
|
|
@ -937,12 +942,12 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
if (!iscons(v)) goto notpair;
|
||||
v = cdr_(v);
|
||||
break;
|
||||
case F_RPLACA:
|
||||
argcount("rplaca", nargs, 2);
|
||||
case F_SETCAR:
|
||||
argcount("set-car!", nargs, 2);
|
||||
car(v=Stack[SP-2]) = Stack[SP-1];
|
||||
break;
|
||||
case F_RPLACD:
|
||||
argcount("rplacd", nargs, 2);
|
||||
case F_SETCDR:
|
||||
argcount("set-cdr!", nargs, 2);
|
||||
cdr(v=Stack[SP-2]) = Stack[SP-1];
|
||||
break;
|
||||
case F_VECTOR:
|
||||
|
|
@ -1015,36 +1020,47 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
break;
|
||||
case F_ATOM:
|
||||
argcount("atom", nargs, 1);
|
||||
v = ((!iscons(Stack[SP-1])) ? T : NIL);
|
||||
argcount("atom?", nargs, 1);
|
||||
v = ((!iscons(Stack[SP-1])) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_CONSP:
|
||||
argcount("consp", nargs, 1);
|
||||
v = (iscons(Stack[SP-1]) ? T : NIL);
|
||||
argcount("pair?", nargs, 1);
|
||||
v = (iscons(Stack[SP-1]) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_SYMBOLP:
|
||||
argcount("symbolp", nargs, 1);
|
||||
v = ((issymbol(Stack[SP-1])) ? T : NIL);
|
||||
argcount("symbol?", nargs, 1);
|
||||
v = ((issymbol(Stack[SP-1])) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_NUMBERP:
|
||||
argcount("numberp", nargs, 1);
|
||||
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL);
|
||||
argcount("number?", nargs, 1);
|
||||
v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_FIXNUMP:
|
||||
argcount("fixnump", nargs, 1);
|
||||
v = (isfixnum(Stack[SP-1]) ? T : NIL);
|
||||
argcount("fixnum?", nargs, 1);
|
||||
v = (isfixnum(Stack[SP-1]) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_BUILTINP:
|
||||
argcount("builtinp", nargs, 1);
|
||||
v = (isbuiltinish(Stack[SP-1]) ? T : NIL);
|
||||
argcount("builtin?", nargs, 1);
|
||||
v = Stack[SP-1];
|
||||
v = ((isbuiltinish(v) && v!=FL_F && v!=FL_T && v!=NIL)
|
||||
? FL_T : FL_F);
|
||||
break;
|
||||
case F_VECTORP:
|
||||
argcount("vectorp", nargs, 1);
|
||||
v = ((isvector(Stack[SP-1])) ? T : NIL);
|
||||
argcount("vector?", nargs, 1);
|
||||
v = ((isvector(Stack[SP-1])) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_NOT:
|
||||
argcount("not", nargs, 1);
|
||||
v = ((Stack[SP-1] == NIL) ? T : NIL);
|
||||
v = ((Stack[SP-1] == FL_F) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_NULL:
|
||||
argcount("null?", nargs, 1);
|
||||
v = ((Stack[SP-1] == NIL) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_BOOLEANP:
|
||||
argcount("boolean?", nargs, 1);
|
||||
v = Stack[SP-1];
|
||||
v = ((v == FL_T || v == FL_F) ? FL_T : FL_F);
|
||||
break;
|
||||
case F_ADD:
|
||||
s = 0;
|
||||
|
|
@ -1157,19 +1173,37 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
case F_LT:
|
||||
argcount("<", nargs, 2);
|
||||
if (bothfixnums(Stack[SP-2], Stack[SP-1])) {
|
||||
v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? T : NIL;
|
||||
v = (numval(Stack[SP-2]) < numval(Stack[SP-1])) ? FL_T : FL_F;
|
||||
}
|
||||
else {
|
||||
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ? T : NIL;
|
||||
v = (numval(compare(Stack[SP-2], Stack[SP-1])) < 0) ?
|
||||
FL_T : FL_F;
|
||||
}
|
||||
break;
|
||||
case F_EQUAL:
|
||||
argcount("equal", nargs, 2);
|
||||
if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
|
||||
v = (Stack[SP-2] == Stack[SP-1]) ? T : NIL;
|
||||
argcount("equal?", nargs, 2);
|
||||
if (Stack[SP-2] == Stack[SP-1]) {
|
||||
v = FL_T;
|
||||
}
|
||||
else if (eq_comparable(Stack[SP-2],Stack[SP-1])) {
|
||||
v = FL_F;
|
||||
}
|
||||
else {
|
||||
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ? T : NIL;
|
||||
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
|
||||
FL_T : FL_F;
|
||||
}
|
||||
break;
|
||||
case F_EQV:
|
||||
argcount("eqv?", nargs, 2);
|
||||
if (Stack[SP-2] == Stack[SP-1]) {
|
||||
v = FL_T;
|
||||
}
|
||||
else if (!leafp(Stack[SP-2]) || !leafp(Stack[SP-1])) {
|
||||
v = FL_F;
|
||||
}
|
||||
else {
|
||||
v = (numval(compare(Stack[SP-2], Stack[SP-1]))==0) ?
|
||||
FL_T : FL_F;
|
||||
}
|
||||
break;
|
||||
case F_EVAL:
|
||||
|
|
@ -1207,9 +1241,9 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
lerror(ArgError, "prog1: too few arguments");
|
||||
v = Stack[saveSP+1];
|
||||
break;
|
||||
case F_ASSOC:
|
||||
argcount("assoc", nargs, 2);
|
||||
v = assoc(Stack[SP-2], Stack[SP-1]);
|
||||
case F_ASSQ:
|
||||
argcount("assq", nargs, 2);
|
||||
v = assq(Stack[SP-2], Stack[SP-1]);
|
||||
break;
|
||||
case F_FOR:
|
||||
argcount("for", nargs, 3);
|
||||
|
|
@ -1224,7 +1258,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
SP += 4; // make space
|
||||
Stack[SP-4] = fixnum(3); // env size
|
||||
Stack[SP-1] = cdr_(cdr_(f)); // cloenv
|
||||
v = NIL;
|
||||
v = FL_F;
|
||||
for(s=lo; s <= hi; s++) {
|
||||
f = Stack[SP-5];
|
||||
Stack[SP-3] = car_(f); // lambda list
|
||||
|
|
@ -1256,6 +1290,10 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
noeval = 1;
|
||||
goto apply_lambda;
|
||||
case F_TRUE:
|
||||
case F_FALSE:
|
||||
case F_NIL:
|
||||
goto apply_type_error;
|
||||
default:
|
||||
// function pointer tagged as a builtin
|
||||
v = ((builtin_t)ptr(f))(&Stack[saveSP+1], nargs);
|
||||
|
|
@ -1358,6 +1396,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
}
|
||||
// not reached
|
||||
}
|
||||
apply_type_error:
|
||||
type_error("apply", "function", f);
|
||||
notpair:
|
||||
lerror(TypeError, "expected cons");
|
||||
|
|
@ -1369,7 +1408,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail)
|
|||
extern void builtins_init();
|
||||
extern void comparehash_init();
|
||||
|
||||
static char *EXEDIR;
|
||||
static char *EXEDIR = NULL;
|
||||
|
||||
void assign_global_builtins(builtinspec_t *b)
|
||||
{
|
||||
|
|
@ -1393,8 +1432,9 @@ void lisp_init(void)
|
|||
htable_new(&printconses, 32);
|
||||
comparehash_init();
|
||||
|
||||
NIL = symbol("nil"); setc(NIL, NIL);
|
||||
T = symbol("T"); setc(T, T);
|
||||
NIL = builtin(F_NIL);
|
||||
FL_T = builtin(F_TRUE);
|
||||
FL_F = builtin(F_FALSE);
|
||||
LAMBDA = symbol("lambda");
|
||||
QUOTE = symbol("quote");
|
||||
TRYCATCH = symbol("trycatch");
|
||||
|
|
@ -1417,12 +1457,17 @@ void lisp_init(void)
|
|||
fixnumsym = symbol("fixnum");
|
||||
vectorsym = symbol("vector");
|
||||
builtinsym = symbol("builtin");
|
||||
defunsym = symbol("defun");
|
||||
defmacrosym = symbol("defmacro");
|
||||
booleansym = symbol("boolean");
|
||||
nullsym = symbol("null");
|
||||
definesym = symbol("define");
|
||||
defmacrosym = symbol("define-macro");
|
||||
forsym = symbol("for");
|
||||
labelsym = symbol("label");
|
||||
setqsym = symbol("setq");
|
||||
set(printprettysym=symbol("*print-pretty*"), T);
|
||||
setqsym = symbol("set!");
|
||||
elsesym = symbol("else");
|
||||
tsym = symbol("t"); Tsym = symbol("T");
|
||||
fsym = symbol("f"); Fsym = symbol("F");
|
||||
set(printprettysym=symbol("*print-pretty*"), FL_T);
|
||||
set(printwidthsym=symbol("*print-width*"), fixnum(SCR_WIDTH));
|
||||
lasterror = NIL;
|
||||
lerrorbuf[0] = '\0';
|
||||
|
|
@ -1433,7 +1478,7 @@ void lisp_init(void)
|
|||
((symbol_t*)ptr(symbol(builtin_names[i])))->syntax = builtin(i);
|
||||
i++;
|
||||
}
|
||||
for (; i < N_BUILTINS; i++) {
|
||||
for (; i < F_TRUE; i++) {
|
||||
setc(symbol(builtin_names[i]), builtin(i));
|
||||
}
|
||||
|
||||
|
|
@ -1559,6 +1604,7 @@ int locale_is_utf8;
|
|||
int main(int argc, char *argv[])
|
||||
{
|
||||
value_t v;
|
||||
char fname_buf[1024];
|
||||
|
||||
locale_is_utf8 = u8_is_locale_utf8(setlocale(LC_ALL, ""));
|
||||
|
||||
|
|
@ -1575,7 +1621,13 @@ int main(int argc, char *argv[])
|
|||
if (argc > 1) return 1;
|
||||
else goto repl;
|
||||
}
|
||||
load_file("system.lsp");
|
||||
fname_buf[0] = '\0';
|
||||
if (EXEDIR != NULL) {
|
||||
strcat(fname_buf, EXEDIR);
|
||||
strcat(fname_buf, PATHSEPSTRING);
|
||||
}
|
||||
strcat(fname_buf, "system.lsp");
|
||||
load_file(fname_buf);
|
||||
if (argc > 1) { load_file(argv[1]); return 0; }
|
||||
printf("; _ \n");
|
||||
printf("; |_ _ _ |_ _ | . _ _\n");
|
||||
|
|
|
|||
|
|
@ -103,18 +103,21 @@ enum {
|
|||
// special forms
|
||||
F_QUOTE=0, F_COND, F_IF, F_AND, F_OR, F_WHILE, F_LAMBDA,
|
||||
F_TRYCATCH, F_SPECIAL_APPLY, F_SETQ, F_PROGN,
|
||||
|
||||
// functions
|
||||
F_EQ, F_ATOM, F_NOT, F_SYMBOLP, F_NUMBERP, F_BOUNDP, F_CONSP,
|
||||
F_BUILTINP, F_VECTORP, F_FIXNUMP, F_EQUAL,
|
||||
F_CONS, F_LIST, F_CAR, F_CDR, F_RPLACA, F_RPLACD,
|
||||
F_EQ, F_EQV, F_EQUAL, F_ATOM, F_NOT, F_NULL, F_BOOLEANP, F_SYMBOLP,
|
||||
F_NUMBERP, F_BOUNDP, F_CONSP, F_BUILTINP, F_VECTORP, F_FIXNUMP,
|
||||
|
||||
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
|
||||
F_EVAL, F_EVALSTAR, F_APPLY, F_PROG1, F_RAISE,
|
||||
F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_BNOT, F_BAND, F_BOR, F_BXOR,
|
||||
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSOC, F_COMPARE, F_FOR,
|
||||
N_BUILTINS
|
||||
F_VECTOR, F_AREF, F_ASET, F_LENGTH, F_ASSQ, F_COMPARE, F_FOR,
|
||||
F_TRUE, F_FALSE, F_NIL,
|
||||
N_BUILTINS,
|
||||
};
|
||||
#define isspecial(v) (uintval(v) <= (unsigned int)F_PROGN)
|
||||
|
||||
extern value_t NIL, T;
|
||||
extern value_t NIL, FL_T, FL_F;
|
||||
|
||||
/* read, eval, print main entry points */
|
||||
value_t read_sexpr(ios_t *f);
|
||||
|
|
|
|||
|
|
@ -0,0 +1,63 @@
|
|||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <stdarg.h>
|
||||
#include <string.h>
|
||||
#include <assert.h>
|
||||
#include <sys/types.h>
|
||||
#include "llt.h"
|
||||
#include "flisp.h"
|
||||
|
||||
// global replace TYPE with your type name to make your very own type!
|
||||
|
||||
static value_t TYPEsym;
|
||||
static fltype_t *TYPEtype;
|
||||
|
||||
void print_TYPE(value_t v, ios_t *f, int princ)
|
||||
{
|
||||
}
|
||||
|
||||
void print_traverse_TYPE(value_t self)
|
||||
{
|
||||
}
|
||||
|
||||
void free_TYPE(value_t self)
|
||||
{
|
||||
}
|
||||
|
||||
void relocate_TYPE(value_t oldv, value_t newv)
|
||||
{
|
||||
}
|
||||
|
||||
cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,
|
||||
print_traverse_TYPE };
|
||||
|
||||
int isTYPE(value_t v)
|
||||
{
|
||||
return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype;
|
||||
}
|
||||
|
||||
value_t fl_TYPEp(value_t *args, uint32_t nargs)
|
||||
{
|
||||
argcount("TYPE?", nargs, 1);
|
||||
return isTYPE(args[0]) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
static TYPE_t *toTYPE(value_t v, char *fname)
|
||||
{
|
||||
if (!isTYPE(v))
|
||||
type_error(fname, "TYPE", v);
|
||||
return (TYPE_t*)cv_data((cvalue_t*)ptr(v));
|
||||
}
|
||||
|
||||
static builtinspec_t TYPEfunc_info[] = {
|
||||
{ "TYPE?", fl_TYPEp },
|
||||
{ NULL, NULL }
|
||||
};
|
||||
|
||||
void TYPE_init()
|
||||
{
|
||||
TYPEsym = symbol("TYPE");
|
||||
TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
|
||||
&TYPE_vtable, NULL);
|
||||
assign_global_builtins(TYPEfunc_info);
|
||||
}
|
||||
|
|
@ -9,17 +9,20 @@
|
|||
(assert (equal (time (yfib 32)) 2178309))
|
||||
|
||||
(princ "sort: ")
|
||||
(setq r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
|
||||
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
|
||||
(time (sort r))
|
||||
|
||||
(princ "mexpand: ")
|
||||
(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
|
||||
|
||||
(princ "append: ")
|
||||
(setq L (map-int (lambda (x) (map-int identity 20)) 20))
|
||||
(set! L (map-int (lambda (x) (map-int identity 20)) 20))
|
||||
(time (dotimes (n 1000) (apply append L)))
|
||||
|
||||
(path.cwd "ast")
|
||||
(princ "p-lambda: ")
|
||||
(load "rpasses.lsp")
|
||||
(define *input* (load "datetimeR.lsp"))
|
||||
(time (set! *output* (compile-ish *input*)))
|
||||
(assert (equal *output* (load "rpasses-out.lsp")))
|
||||
(path.cwd "..")
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
(defun pisum ()
|
||||
(define (pisum)
|
||||
(dotimes (j 500)
|
||||
((label sumloop
|
||||
(lambda (i sum)
|
||||
|
|
|
|||
|
|
@ -169,7 +169,7 @@ static int smallp(value_t v)
|
|||
static int specialindent(value_t head)
|
||||
{
|
||||
// indent these forms 2 spaces, not lined up with the first argument
|
||||
if (head == LAMBDA || head == TRYCATCH || head == defunsym ||
|
||||
if (head == LAMBDA || head == TRYCATCH || head == definesym ||
|
||||
head == defmacrosym || head == forsym || head == labelsym)
|
||||
return 2;
|
||||
return -1;
|
||||
|
|
@ -200,7 +200,13 @@ static int allsmallp(value_t v)
|
|||
static int indentafter3(value_t head, value_t v)
|
||||
{
|
||||
// for certain X always indent (X a b c) after b
|
||||
return ((head == defunsym || head == defmacrosym || head == forsym) &&
|
||||
return ((head == forsym) && !allsmallp(cdr_(v)));
|
||||
}
|
||||
|
||||
static int indentafter2(value_t head, value_t v)
|
||||
{
|
||||
// for certain X always indent (X a b) after a
|
||||
return ((head == definesym || head == defmacrosym) &&
|
||||
!allsmallp(cdr_(v)));
|
||||
}
|
||||
|
||||
|
|
@ -251,6 +257,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
|
|||
if (!blk) always = indentevery(v);
|
||||
value_t head = car_(v);
|
||||
int after3 = indentafter3(head, v);
|
||||
int after2 = indentafter2(head, v);
|
||||
int n_unindented = 1;
|
||||
while (1) {
|
||||
lastv = VPOS;
|
||||
|
|
@ -287,6 +294,7 @@ static void print_pair(ios_t *f, value_t v, int princ)
|
|||
(n > 0 && always) ||
|
||||
|
||||
(n == 2 && after3) ||
|
||||
(n == 1 && after2) ||
|
||||
|
||||
(n_unindented >= 3 && !nextsmall) ||
|
||||
|
||||
|
|
@ -328,8 +336,6 @@ void fl_print_child(ios_t *f, value_t v, int princ)
|
|||
name = symbol_name(v);
|
||||
if (princ)
|
||||
outs(name, f);
|
||||
else if (v == NIL)
|
||||
outs("()", f);
|
||||
else if (ismanaged(v)) {
|
||||
outs("#:", f);
|
||||
outs(name, f);
|
||||
|
|
@ -338,6 +344,18 @@ void fl_print_child(ios_t *f, value_t v, int princ)
|
|||
print_symbol_name(f, name);
|
||||
break;
|
||||
case TAG_BUILTIN:
|
||||
if (v == FL_T) {
|
||||
outs("#t", f);
|
||||
break;
|
||||
}
|
||||
if (v == FL_F) {
|
||||
outs("#f", f);
|
||||
break;
|
||||
}
|
||||
if (v == NIL) {
|
||||
outs("()", f);
|
||||
break;
|
||||
}
|
||||
if (isbuiltin(v)) {
|
||||
outs("#.", f);
|
||||
outs(builtin_names[uintval(v)], f);
|
||||
|
|
@ -624,7 +642,7 @@ static void set_print_width()
|
|||
|
||||
void print(ios_t *f, value_t v, int princ)
|
||||
{
|
||||
print_pretty = (symbol_value(printprettysym) != NIL);
|
||||
print_pretty = (symbol_value(printprettysym) != FL_F);
|
||||
if (print_pretty)
|
||||
set_print_width();
|
||||
printlabel = 0;
|
||||
|
|
|
|||
|
|
@ -270,12 +270,6 @@ static u_int32_t peek(ios_t *f)
|
|||
read_token(f, ch, 0);
|
||||
toktype = TOK_SHARPSYM;
|
||||
tokval = symbol(buf);
|
||||
c = nextchar(f);
|
||||
if (c != '(') {
|
||||
take();
|
||||
lerror(ParseError, "read: expected argument list for %s",
|
||||
symbol_name(tokval));
|
||||
}
|
||||
}
|
||||
else {
|
||||
lerror(ParseError, "read: unknown read macro");
|
||||
|
|
||||