diff --git a/femtolisp/ast/asttools.lsp b/femtolisp/ast/asttools.lsp index ba119a1..3e73a54 100644 --- a/femtolisp/ast/asttools.lsp +++ b/femtolisp/ast/asttools.lsp @@ -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))))) diff --git a/femtolisp/ast/match.lsp b/femtolisp/ast/match.lsp index 6c2e5a8..8091905 100644 --- a/femtolisp/ast/match.lsp +++ b/femtolisp/ast/match.lsp @@ -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 diff --git a/femtolisp/ast/rpasses-out.lsp b/femtolisp/ast/rpasses-out.lsp new file mode 100644 index 0000000..e87613c --- /dev/null +++ b/femtolisp/ast/rpasses-out.lsp @@ -0,0 +1,1710 @@ +'(r-expressions (<- Sys.time (lambda () + (let () (r-block (r-call structure (r-call + .Internal (r-call + Sys.time)) + (*named* class (r-call + c "POSIXt" "POSIXct"))))))) + (<- Sys.timezone (lambda () + (let () (r-block (r-call as.vector (r-call + Sys.getenv "TZ")))))) + (<- as.POSIXlt (lambda (x tz) + (let ((x ()) (tzone ()) (fromchar ()) (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- fromchar (lambda (x) + (let ((res ()) (f + ()) + (j ()) (xx ())) + (r-block (<- + xx (r-call r-index x 1)) + (if (r-call is.na xx) + (r-block (<- j 1) (while (&& (r-call is.na xx) + (r-call <= (<- j (r-call + j 1)) + (r-call length x))) + (<- xx (r-call r-index x j))) + (if (r-call is.na xx) + (<- f "%Y-%m-%d")))) + (if (|\|\|| (r-call is.na xx) (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y-%m-%d %H:%M:%OS")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d %H:%M:%OS")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y-%m-%d %H:%M")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d %H:%M")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y-%m-%d")))) + (r-call ! (r-call is.na (r-call strptime xx + (<- f "%Y/%m/%d"))))) + (r-block (<- res (r-call strptime x f)) + (if (r-call nchar tz) + (r-block (<- res (r-call attr<- res + "tzone" tz)) + tz)) + (return res))) + (r-call stop "character string is not in a standard unambiguous format"))))) + (if (r-call inherits x + "POSIXlt") + (return x)) + (if (r-call inherits x + "Date") + (return (r-call .Internal (r-call + Date2POSIXlt x)))) + (<- tzone (r-call attr x + "tzone")) + (if (|\|\|| (r-call inherits x + "date") + (r-call inherits x + "dates")) + (<- x (r-call as.POSIXct x))) + (if (r-call is.character x) + (return (r-call fromchar (r-call + unclass x)))) + (if (r-call is.factor x) + (return (r-call fromchar (r-call + as.character x)))) + (if (&& (r-call is.logical x) + (r-call all (r-call is.na + x))) + (<- x (r-call + as.POSIXct.default x))) + (if (r-call ! (r-call inherits x + "POSIXct")) + (r-call stop (r-call gettextf + "do not know how to convert '%s' to class \"POSIXlt\"" + (r-call deparse (substitute x))))) + (if (&& (missing tz) + (r-call ! (r-call is.null + tzone))) + (<- tz (r-call r-index tzone + 1))) + (r-call .Internal (r-call + as.POSIXlt x + tz)))))) + (<- as.POSIXct (lambda (x tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (r-call UseMethod "as.POSIXct"))))) + (<- as.POSIXct.Date (lambda (x ...) + (let () (r-block (r-call structure (r-call + * (r-call unclass x) 86400) + (*named* class (r-call + c "POSIXt" "POSIXct"))))))) + (<- as.POSIXct.date (lambda (x ...) + (let ((x ())) + (r-block (if (r-call inherits x + "date") + (r-block (<- x (r-call + * (r-call - x 3653) 86400)) + (return (r-call + structure x (*named* class (r-call c "POSIXt" + "POSIXct"))))) + (r-call stop (r-call + gettextf "'%s' is not a \"date\" object" + (r-call deparse (substitute x))))))))) + (<- as.POSIXct.dates (lambda (x ...) + (let ((x ()) (z ())) + (r-block (if (r-call inherits x + "dates") + (r-block (<- z (r-call + attr x "origin")) + (<- x (r-call + * (r-call as.numeric x) 86400)) + (if (&& (r-call + == (r-call length z) 3) + (r-call is.numeric z)) + (<- x (r-call + x + (r-call as.numeric (r-call ISOdate (r-call r-index z 3) + (r-call r-index z 1) + (r-call r-index z 2) 0))))) + (return (r-call + structure x (*named* class (r-call c "POSIXt" + "POSIXct"))))) + (r-call stop (r-call + gettextf "'%s' is not a \"dates\" object" + (r-call deparse (substitute x))))))))) + (<- as.POSIXct.POSIXlt (lambda (x tz) + (let ((tzone ()) (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- tzone (r-call attr x + "tzone")) + (if (&& (missing tz) + (r-call ! (r-call + is.null tzone))) + (<- tz (r-call + r-index tzone + 1))) + (r-call structure (r-call + .Internal (r-call as.POSIXct x tz)) + (*named* class (r-call + c "POSIXt" "POSIXct")) + (*named* tzone tz)))))) + (<- as.POSIXct.default (lambda (x tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (if (r-call inherits x + "POSIXct") + (return x)) + (if (|\|\|| (r-call + is.character + x) + (r-call + is.factor x)) + (return (r-call + as.POSIXct + (r-call + as.POSIXlt + x) + tz))) + (if (&& (r-call + is.logical x) + (r-call all (r-call + is.na x))) + (return (r-call + structure (r-call + as.numeric x) + (*named* + class (r-call + c "POSIXt" "POSIXct"))))) + (r-call stop (r-call + gettextf "do not know how to convert '%s' to class \"POSIXlt\"" + (r-call + deparse (substitute x)))))))) + (<- as.numeric.POSIXlt (lambda (x) + (let () (r-block (r-call as.POSIXct x))))) + (<- format.POSIXlt (lambda (x format usetz ...) + (let ((np ()) (secs ()) (times ()) (format + ()) + (usetz ())) + (r-block (when (missing usetz) + (<- usetz *r-false*)) + (when (missing format) + (<- format "")) + (if (r-call ! (r-call + inherits x "POSIXlt")) + (r-call stop "wrong class")) + (if (r-call == format + "") + (r-block (<- times (r-call + unlist (r-call r-index (r-call unclass x) + (r-call : 1 3)))) + (<- secs (r-call + r-aref x (index-in-strlist sec (r-call attr x + #0="names")))) + (<- secs (r-call + r-index secs (r-call ! (r-call is.na secs)))) + (<- np (r-call + getOption "digits.secs")) + (if (r-call + is.null np) + (<- np 0) + (<- np (r-call + min 6 np))) + (if (r-call >= + np 1) + (r-block (for + i (r-call - (r-call : 1 np) 1) + (if (r-call all (r-call < (r-call abs (r-call - secs + (r-call round secs i))) + 9.9999999999999995e-07)) + (r-block (<- np i) (break)))))) + (<- format (if + (r-call all (r-call == (r-call r-index times + (r-call ! (r-call is.na times))) + 0)) + "%Y-%m-%d" + (if (r-call == np 0) + "%Y-%m-%d %H:%M:%S" + (r-call paste "%Y-%m-%d %H:%M:%OS" np + (*named* sep ""))))))) + (r-call .Internal (r-call + format.POSIXlt x format usetz)))))) + (<- strftime format.POSIXlt) + (<- strptime (lambda (x format tz) + (let ((tz ())) + (r-block (when (missing tz) + (<- tz "")) + (r-call .Internal (r-call strptime + (r-call as.character x) format tz)))))) + (<- format.POSIXct (lambda (x format tz usetz ...) + (let ((tzone ()) (format ()) (tz ()) (usetz + ())) + (r-block (when (missing usetz) + (<- usetz *r-false*)) + (when (missing tz) + (<- tz "")) + (when (missing format) + (<- format "")) + (if (r-call ! (r-call + inherits x "POSIXct")) + (r-call stop "wrong class")) + (if (&& (missing tz) + (r-call ! (r-call + is.null (<- tzone (r-call attr x + "tzone"))))) + (<- tz tzone)) + (r-call structure (r-call + format.POSIXlt (r-call as.POSIXlt x tz) format usetz r-dotdotdot) + (*named* names (r-call + names x))))))) + (<- print.POSIXct (lambda (x ...) + (let () (r-block (r-call print (r-call + format x (*named* + usetz *r-true*) + r-dotdotdot) + r-dotdotdot) + (r-call invisible x))))) + (<- print.POSIXlt (lambda (x ...) + (let () (r-block (r-call print (r-call + format x (*named* + usetz *r-true*)) + r-dotdotdot) + (r-call invisible x))))) + (<- summary.POSIXct (lambda (object digits ...) + (let ((x ()) (digits ())) + (r-block (when (missing digits) + (<- digits 15)) + (<- x (r-call r-index (r-call + summary.default (r-call unclass object) + (*named* digits digits) r-dotdotdot) + (r-call : 1 6))) + (r-block (ref= %r:1 (r-call + oldClass object)) + (<- x (r-call + class<- x + %r:1)) + %r:1) + (r-block (ref= %r:2 (r-call + attr object "tzone")) + (<- x (r-call + attr<- x "tzone" + %r:2)) + %r:2) + x)))) + (<- summary.POSIXlt (lambda (object digits ...) + (let ((digits ())) + (r-block (when (missing digits) + (<- digits 15)) + (r-call summary (r-call + as.POSIXct + object) + (*named* digits + digits) + r-dotdotdot))))) + (<- "+.POSIXt" (lambda (e1 e2) + (let ((e2 ()) (e1 ()) (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block + (switch (r-call attr x + "units") + (*named* secs x) (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) + x))))))) + (if (r-call == (r-call nargs) 1) + (return e1)) + (if (&& (r-call inherits e1 + "POSIXt") + (r-call inherits e2 + "POSIXt")) + (r-call stop "binary + is not defined for \"POSIXt\" objects")) + (if (r-call inherits e1 + "POSIXlt") + (<- e1 (r-call as.POSIXct e1))) + (if (r-call inherits e2 + "POSIXlt") + (<- e2 (r-call as.POSIXct e2))) + (if (r-call inherits e1 + "difftime") + (<- e1 (r-call coerceTimeUnit + e1))) + (if (r-call inherits e2 + "difftime") + (<- e2 (r-call coerceTimeUnit + e2))) + (r-call structure (r-call + (r-call + unclass e1) + (r-call unclass e2)) + (*named* class (r-call c + "POSIXt" "POSIXct")) + (*named* tzone (r-call + check_tzones e1 e2))))))) + (<- "-.POSIXt" (lambda (e1 e2) + (let ((e2 ()) (coerceTimeUnit ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block + (switch (r-call attr x + "units") + (*named* secs x) (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) 24) x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call * 60 60) 24) 7) + x))))))) + (if (r-call ! (r-call inherits e1 + "POSIXt")) + (r-call stop "Can only subtract from POSIXt objects")) + (if (r-call == (r-call nargs) 1) + (r-call stop "unary - is not defined for \"POSIXt\" objects")) + (if (r-call inherits e2 + "POSIXt") + (return (r-call difftime e1 + e2))) + (if (r-call inherits e2 + "difftime") + (<- e2 (r-call unclass (r-call + coerceTimeUnit e2)))) + (if (r-call ! (r-call is.null (r-call + attr e2 "class"))) + (r-call stop "can only subtract numbers from POSIXt objects")) + (r-call structure (r-call - (r-call + unclass (r-call as.POSIXct e1)) + e2) + (*named* class (r-call c + "POSIXt" "POSIXct"))))))) + (<- Ops.POSIXt (lambda (e1 e2) + (let ((e2 ()) (e1 ()) (boolean ())) + (r-block (if (r-call == (r-call nargs) 1) + (r-call stop "unary" .Generic + " not defined for \"POSIXt\" objects")) + (<- boolean (switch .Generic (*named* + < *r-missing*) + (*named* > + *r-missing*) + (*named* == + *r-missing*) + (*named* != + *r-missing*) + (*named* <= + *r-missing*) + (*named* >= + *r-true*) + *r-false*)) + (if (r-call ! boolean) + (r-call stop .Generic + " not defined for \"POSIXt\" objects")) + (if (|\|\|| (r-call inherits e1 + "POSIXlt") + (r-call is.character + e1)) + (<- e1 (r-call as.POSIXct e1))) + (if (|\|\|| (r-call inherits e2 + "POSIXlt") + (r-call is.character + e1)) + (<- e2 (r-call as.POSIXct e2))) + (r-call check_tzones e1 e2) + (r-call NextMethod .Generic))))) + (<- Math.POSIXt (lambda (x ...) + (let () (r-block (r-call stop .Generic + " not defined for POSIXt objects"))))) + (<- check_tzones (lambda (...) + (let ((tzs ())) + (r-block (<- tzs (r-call unique (r-call + sapply (r-call list r-dotdotdot) (lambda (x) + (let ((y ())) + (r-block (<- y (r-call attr x + "tzone")) + (if (r-call is.null y) + "" + y))))))) + (<- tzs (r-call r-index tzs + (r-call != tzs + ""))) + (if (r-call > (r-call length + tzs) + 1) + (r-call warning "'tzone' attributes are inconsistent")) + (if (r-call length tzs) + (r-call r-index tzs 1) + ()))))) + (<- Summary.POSIXct (lambda (... na.rm) + (let ((val ()) (tz ()) (args ()) (ok ())) + (r-block (<- ok (switch .Generic (*named* + max *r-missing*) + (*named* min + *r-missing*) + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"POSIXct\" objects")) + (<- args (r-call list + r-dotdotdot)) + (<- tz (r-call do.call "check_tzones" + args)) + (<- val (r-call NextMethod + .Generic)) + (r-block (ref= %r:3 (r-call + oldClass (r-call r-aref args 1))) + (<- val (r-call + class<- val %r:3)) + %r:3) + (r-block (<- val (r-call + attr<- val "tzone" tz)) + tz) + val)))) + (<- Summary.POSIXlt (lambda (... na.rm) + (let ((val ()) (tz ()) (args ()) (ok ())) + (r-block (<- ok (switch .Generic (*named* + max *r-missing*) + (*named* min + *r-missing*) + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"POSIXlt\" objects")) + (<- args (r-call list + r-dotdotdot)) + (<- tz (r-call do.call "check_tzones" + args)) + (<- args (r-call lapply args + as.POSIXct)) + (<- val (r-call do.call + .Generic (r-call + c args (*named* na.rm na.rm)))) + (r-call as.POSIXlt (r-call + structure val (*named* class (r-call c "POSIXt" + "POSIXct")) + (*named* tzone tz))))))) + (<- "[.POSIXct" (lambda (x ... drop) + (let ((val ()) (x ()) (cl ()) (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- + x ())) + ()) + (<- val (r-call NextMethod "[")) + (r-block (<- val (r-call class<- + val cl)) + cl) + (r-block (ref= %r:4 (r-call attr + x "tzone")) + (<- val (r-call attr<- + val "tzone" %r:4)) + %r:4) + val)))) + (<- "[[.POSIXct" (lambda (x ... drop) + (let ((val ()) (x ()) (cl ()) (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- + x ())) + ()) + (<- val (r-call NextMethod "[[")) + (r-block (<- val (r-call + class<- val + cl)) + cl) + (r-block (ref= %r:5 (r-call + attr x "tzone")) + (<- val (r-call attr<- + val "tzone" %r:5)) + %r:5) + val)))) + (<- "[<-.POSIXct" (lambda (x ... value) + (let ((x ()) (tz ()) (cl ()) (value ())) + (r-block (if (r-call ! (r-call + as.logical (r-call + length value))) + (return x)) + (<- value (r-call as.POSIXct + value)) + (<- cl (r-call oldClass x)) + (<- tz (r-call attr x + "tzone")) + (r-block (ref= %r:6 (r-block + (<- value (r-call class<- value ())) ())) + (<- x (r-call class<- + x %r:6)) + %r:6) + (<- x (r-call NextMethod + .Generic)) + (r-block (<- x (r-call class<- + x cl)) + cl) + (r-block (<- x (r-call attr<- + x "tzone" tz)) + tz) + x)))) + (<- as.character.POSIXt (lambda (x ...) + (let () (r-block (r-call format x + r-dotdotdot))))) + (<- as.data.frame.POSIXct as.data.frame.vector) + (<- is.na.POSIXlt (lambda (x) + (let () (r-block (r-call is.na (r-call + as.POSIXct + x)))))) + (<- c.POSIXct (lambda (... recursive) + (let ((recursive ())) + (r-block (when (missing recursive) + (<- recursive *r-false*)) + (r-call structure (r-call c (r-call + unlist (r-call lapply (r-call list r-dotdotdot) unclass))) + (*named* class (r-call c + "POSIXt" "POSIXct"))))))) + (<- c.POSIXlt (lambda (... recursive) + (let ((recursive ())) + (r-block (when (missing recursive) + (<- recursive *r-false*)) + (r-call as.POSIXlt (r-call do.call + "c" (r-call lapply (r-call list r-dotdotdot) as.POSIXct))))))) + (<- all.equal.POSIXct (lambda (target current ... scale) + (let ((scale ())) + (r-block (when (missing scale) + (<- scale 1)) + (r-call check_tzones + target current) + (r-call NextMethod "all.equal"))))) + (<- ISOdatetime (lambda (year month day hour min sec tz) + (let ((x ()) (tz ())) + (r-block (when (missing tz) + (<- tz "")) + (<- x (r-call paste year month + day hour min sec + (*named* sep "-"))) + (r-call as.POSIXct (r-call + strptime x + "%Y-%m-%d-%H-%M-%OS" + (*named* tz + tz)) + (*named* tz tz)))))) + (<- ISOdate (lambda (year month day hour min sec tz) + (let ((hour ()) (min ()) (sec ()) (tz ())) + (r-block (when (missing tz) + (<- tz "GMT")) + (when (missing sec) + (<- sec 0)) + (when (missing min) + (<- min 0)) + (when (missing hour) + (<- hour 12)) + (r-call ISOdatetime year month day + hour min sec tz))))) + (<- as.matrix.POSIXlt (lambda (x ...) + (let () (r-block (r-call as.matrix (r-call + as.data.frame (r-call unclass x)) + r-dotdotdot))))) + (<- mean.POSIXct (lambda (x ...) + (let () (r-block (r-call structure (r-call + mean (r-call unclass x) r-dotdotdot) + (*named* class (r-call + c "POSIXt" "POSIXct")) + (*named* tzone (r-call + attr x "tzone"))))))) + (<- mean.POSIXlt (lambda (x ...) + (let () (r-block (r-call as.POSIXlt (r-call + mean (r-call as.POSIXct x) r-dotdotdot)))))) + (<- difftime (lambda (time1 time2 tz units) + (let ((zz ()) (z ()) (time2 ()) (time1 ()) (tz ()) + (units ())) + (r-block (when (missing units) + (<- units (r-call c "auto" + "secs" + "mins" + "hours" + "days" + "weeks"))) + (when (missing tz) + (<- tz "")) + (<- time1 (r-call as.POSIXct time1 + (*named* tz tz))) + (<- time2 (r-call as.POSIXct time2 + (*named* tz tz))) + (<- z (r-call - (r-call unclass + time1) + (r-call unclass time2))) + (<- units (r-call match.arg units)) + (if (r-call == units + "auto") + (r-block (if (r-call all (r-call + is.na z)) + (<- units "secs") + (r-block (<- zz (r-call + min (r-call abs z) (*named* na.rm *r-true*))) + (if (|\|\|| (r-call is.na zz) (r-call < zz 60)) + (<- units "secs") + (if (r-call < zz 3600) + (<- units "mins") + (if (r-call < zz 86400) + (<- units "hours") + (<- units "days")))))))) + (switch units (*named* secs (r-call + structure z (*named* units "secs") + (*named* class "difftime"))) + (*named* mins (r-call + structure (r-call + / z 60) + (*named* + units "mins") + (*named* + class "difftime"))) + (*named* hours (r-call + structure + (r-call / + z 3600) + (*named* + units "hours") + (*named* + class "difftime"))) + (*named* days (r-call + structure (r-call + / z 86400) + (*named* + units "days") + (*named* + class "difftime"))) + (*named* weeks (r-call + structure + (r-call / + z (r-call * 7 86400)) + (*named* + units "weeks") + (*named* + class "difftime")))))))) + (<- as.difftime (lambda (tim format units) + (let ((format ()) (units ())) + (r-block (when (missing units) + (<- units "auto")) + (when (missing format) + (<- format "%X")) + (if (r-call inherits tim + "difftime") + (return tim)) + (if (r-call is.character tim) + (r-block (r-call difftime (r-call + strptime tim (*named* format format)) + (r-call + strptime "0:0:0" (*named* format "%X")) + (*named* + units units))) + (r-block (if (r-call ! (r-call + is.numeric tim)) + (r-call stop "'tim' is not character or numeric")) + (if (r-call == + units "auto") + (r-call stop "need explicit units for numeric conversion")) + (if (r-call ! (r-call + %in% units (r-call c "secs" + "mins" "hours" "days" + "weeks"))) + (r-call stop "invalid units specified")) + (r-call structure + tim (*named* + units units) + (*named* + class "difftime")))))))) + (<- units (lambda (x) + (let () (r-block (r-call UseMethod "units"))))) + (<- "units<-" (lambda (x value) + (let () (r-block (r-call UseMethod "units<-"))))) + (<- units.difftime (lambda (x) + (let () (r-block (r-call attr x + "units"))))) + (<- "units<-.difftime" (lambda (x value) + (let ((newx ()) (sc ()) (from ())) + (r-block (<- from (r-call units x)) + (if (r-call == from value) + (return x)) + (if (r-call ! (r-call + %in% value (r-call c "secs" + "mins" "hours" "days" + "weeks"))) + (r-call stop "invalid units specified")) + (<- sc (r-call cumprod (r-call + c (*named* secs 1) (*named* mins 60) + (*named* hours 60) (*named* days 24) (*named* weeks 7)))) + (<- newx (r-call / (r-call + * (r-call as.vector x) (r-call r-index sc from)) + (r-call r-index sc value))) + (r-call structure newx + (*named* units + value) + (*named* class "difftime")))))) + (<- as.double.difftime (lambda (x units ...) + (let ((x ()) (units ())) + (r-block (when (missing units) + (<- units "auto")) + (if (r-call != units + "auto") + (r-block (<- x (r-call + units<- x units)) + units)) + (r-call as.double (r-call + as.vector x)))))) + (<- as.data.frame.difftime + as.data.frame.vector) + (<- format.difftime (lambda (x ...) + (let () (r-block (r-call paste (r-call + format (r-call unclass x) r-dotdotdot) + (r-call units x)))))) + (<- print.difftime (lambda (x digits ...) + (let ((y ()) (digits ())) + (r-block (when (missing digits) + (<- digits (r-call + getOption + "digits"))) + (if (|\|\|| (r-call is.array + x) + (r-call > (r-call + length x) + 1)) + (r-block (r-call cat "Time differences in " + (r-call attr x + "units") + "\n" (*named* sep "")) + (<- y (r-call + unclass x)) + (r-block (<- y + (r-call attr<- y + "units" ())) + ()) + (r-call print y)) + (r-call cat "Time difference of " + (r-call format (r-call + unclass x) + (*named* digits digits)) + " " + (r-call attr x + "units") + "\n" + (*named* sep ""))) + (r-call invisible x))))) + (<- round.difftime (lambda (x digits ...) + (let ((units ()) (digits ())) + (r-block (when (missing digits) + (<- digits 0)) + (<- units (r-call attr x + "units")) + (r-call structure (r-call + NextMethod) + (*named* units units) + (*named* class "difftime")))))) + (<- "[.difftime" (lambda (x ... drop) + (let ((val ()) (x ()) (cl ()) (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- cl (r-call oldClass x)) + (r-block (<- x (r-call class<- + x ())) + ()) + (<- val (r-call NextMethod "[")) + (r-block (<- val (r-call + class<- val + cl)) + cl) + (r-block (ref= %r:7 (r-call + attr x "units")) + (<- val (r-call attr<- + val "units" %r:7)) + %r:7) + val)))) + (<- Ops.difftime (lambda (e1 e2) + (let ((u1 ()) (e2 ()) (boolean ()) (e1 ()) (coerceTimeUnit + ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block (switch (r-call attr x + "units") + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call * 60 60) x)) + (*named* days (r-call * (r-call * (r-call * 60 60) + 24) + x)) + (*named* weeks (r-call * (r-call * (r-call * (r-call + * 60 60) + 24) + 7) + x))))))) + (if (r-call == (r-call nargs) + 1) + (r-block (switch .Generic + (*named* + (r-block)) (*named* - (r-block (r-block (ref= %r:8 (r-call - (r-call + unclass e1))) + (<- e1 (r-call r-index<- + e1 + *r-missing* + %r:8)) + %r:8))) + (r-call stop "unary" .Generic + " not defined for \"difftime\" objects")) + (return e1))) + (<- boolean (switch .Generic (*named* + < *r-missing*) + (*named* > + *r-missing*) + (*named* == + *r-missing*) + (*named* != + *r-missing*) + (*named* <= + *r-missing*) + (*named* >= + *r-true*) + *r-false*)) + (if boolean + (r-block (if (&& (r-call + inherits e1 "difftime") + (r-call inherits e2 + "difftime")) + (r-block (<- + e1 (r-call coerceTimeUnit e1)) + (<- e2 (r-call coerceTimeUnit e2)))) + (r-call NextMethod + .Generic)) + (if (|\|\|| (r-call == + .Generic "+") + (r-call == + .Generic "-")) + (r-block (if (&& (r-call + inherits e1 "difftime") + (r-call ! (r-call inherits e2 + "difftime"))) + (return (r-call structure (r-call NextMethod .Generic) + (*named* units (r-call attr e1 + "units")) + (*named* class "difftime")))) + (if (&& (r-call + ! (r-call inherits e1 + "difftime")) + (r-call inherits e2 + "difftime")) + (return (r-call structure (r-call NextMethod .Generic) + (*named* units (r-call attr e2 + "units")) + (*named* class "difftime")))) + (<- u1 (r-call + attr e1 "units")) + (if (r-call == + (r-call attr e2 + "units") + u1) + (r-block (r-call structure (r-call NextMethod .Generic) + (*named* units u1) (*named* class "difftime"))) + (r-block (<- e1 (r-call coerceTimeUnit e1)) + (<- e2 (r-call coerceTimeUnit e2)) + (r-call structure (r-call NextMethod .Generic) + (*named* units "secs") + (*named* class "difftime"))))) + (r-block (r-call stop + .Generic "not defined for \"difftime\" objects")))))))) + (<- "*.difftime" (lambda (e1 e2) + (let ((e2 ()) (e1 ()) (tmp ())) + (r-block (if (&& (r-call inherits e1 + "difftime") + (r-call inherits e2 + "difftime")) + (r-call stop "both arguments of * cannot be \"difftime\" objects")) + (if (r-call inherits e2 + "difftime") + (r-block (<- tmp e1) + (<- e1 e2) + (<- e2 tmp))) + (r-call structure (r-call * e2 + (r-call unclass e1)) + (*named* units (r-call + attr e1 "units")) + (*named* class "difftime")))))) + (<- "/.difftime" (lambda (e1 e2) + (let () (r-block (if (r-call inherits e2 + "difftime") + (r-call stop "second argument of / cannot be a \"difftime\" object")) + (r-call structure (r-call / + (r-call unclass e1) e2) + (*named* units (r-call + attr e1 "units")) + (*named* class "difftime")))))) + (<- Math.difftime (lambda (x ...) + (let () (r-block (r-call stop .Generic + "not defined for \"difftime\" objects"))))) + (<- mean.difftime (lambda (x ... na.rm) + (let ((args ()) (coerceTimeUnit ()) (na.rm + ())) + (r-block (when (missing na.rm) + (<- na.rm *r-false*)) + (<- coerceTimeUnit (lambda (x) + (let () (r-block (r-call as.vector (switch (r-call attr x + "units") + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call + * 60 60) + x)) + (*named* days (r-call * (r-call * + (r-call * 60 60) 24) + x)) + (*named* weeks (r-call * (r-call + * (r-call * (r-call * 60 60) 24) 7) + x)))))))) + (if (r-call length (r-call + list r-dotdotdot)) + (r-block (<- args (r-call + c (r-call lapply (r-call list x r-dotdotdot) coerceTimeUnit) + (*named* na.rm na.rm))) + (r-call structure + (r-call do.call "mean" args) (*named* units "secs") + (*named* class "difftime"))) + (r-block (r-call structure + (r-call mean (r-call as.vector x) + (*named* na.rm na.rm)) + (*named* units (r-call attr x + "units")) + (*named* class "difftime")))))))) + (<- Summary.difftime (lambda (... na.rm) + (let ((args ()) (ok ()) (coerceTimeUnit + ())) + (r-block (<- coerceTimeUnit (lambda (x) + (let () (r-block (r-call as.vector (switch (r-call attr x + "units") + (*named* secs x) + (*named* mins (r-call * 60 x)) + (*named* hours (r-call * (r-call + * 60 60) + x)) + (*named* days (r-call * (r-call * + (r-call * 60 60) 24) + x)) + (*named* weeks (r-call * (r-call + * (r-call * (r-call * 60 60) 24) 7) + x)))))))) + (<- ok (switch .Generic (*named* + max *r-missing*) + (*named* min + *r-missing*) + (*named* + range + *r-true*) + *r-false*)) + (if (r-call ! ok) + (r-call stop .Generic + " not defined for \"difftime\" objects")) + (<- args (r-call c (r-call + lapply (r-call list r-dotdotdot) coerceTimeUnit) + (*named* na.rm na.rm))) + (r-call structure (r-call + do.call .Generic args) + (*named* units "secs") + (*named* class "difftime")))))) + (<- seq.POSIXt (lambda (from to by length.out along.with ...) + (let ((mon ()) (yr ()) (r1 ()) (by2 ()) (by ()) + (valid ()) (res ()) (to ()) (from ()) (status + ()) + (tz ()) (cfrom ()) (length.out ()) (along.with + ())) + (r-block (when (missing along.with) + (<- along.with ())) + (when (missing length.out) + (<- length.out ())) + (if (missing from) + (r-call stop "'from' must be specified")) + (if (r-call ! (r-call inherits + from "POSIXt")) + (r-call stop "'from' must be a POSIXt object")) + (<- cfrom (r-call as.POSIXct from)) + (if (r-call != (r-call length + cfrom) + 1) + (r-call stop "'from' must be of length 1")) + (<- tz (r-call attr cfrom + "tzone")) + (if (r-call ! (missing to)) + (r-block (if (r-call ! (r-call + inherits to "POSIXt")) + (r-call stop "'to' must be a POSIXt object")) + (if (r-call != (r-call + length (r-call as.POSIXct to)) + 1) + (r-call stop "'to' must be of length 1")))) + (if (r-call ! (missing along.with)) + (r-block (<- length.out (r-call + length along.with))) + (if (r-call ! (r-call is.null + length.out)) + (r-block (if (r-call != + (r-call length length.out) 1) + (r-call stop + "'length.out' must be of length 1")) + (<- length.out + (r-call + ceiling + length.out))))) + (<- status (r-call c (r-call ! (missing + to)) + (r-call ! (missing + by)) + (r-call ! (r-call + is.null length.out)))) + (if (r-call != (r-call sum status) + 2) + (r-call stop "exactly two of 'to', 'by' and 'length.out' / 'along.with' must be specified")) + (if (missing by) + (r-block (<- from (r-call + unclass cfrom)) + (<- to (r-call + unclass (r-call + as.POSIXct to))) + (<- res (r-call + seq.int + from to (*named* + length.out length.out))) + (return (r-call + structure + res (*named* + class (r-call c "POSIXt" + "POSIXct")) + (*named* + tzone tz))))) + (if (r-call != (r-call length by) + 1) + (r-call stop "'by' must be of length 1")) + (<- valid 0) + (if (r-call inherits by + "difftime") + (r-block (<- by (r-call * (switch + (r-call attr by + "units") + (*named* secs 1) (*named* mins 60) (*named* hours 3600) + (*named* days 86400) (*named* weeks (r-call * 7 86400))) + (r-call unclass by)))) + (if (r-call is.character by) + (r-block (<- by2 (r-call + r-aref (r-call strsplit by + " " (*named* fixed *r-true*)) + 1)) + (if (|\|\|| (r-call + > (r-call length by2) 2) + (r-call < (r-call length by2) 1)) + (r-call stop + "invalid 'by' string")) + (<- valid (r-call + pmatch (r-call r-index by2 + (r-call length by2)) + (r-call c "secs" + "mins" "hours" "days" + "weeks" "months" "years" + "DSTdays"))) + (if (r-call + is.na valid) + (r-call stop + "invalid string for 'by'")) + (if (r-call <= + valid 5) + (r-block (<- + by (r-call r-index (r-call c 1 60 3600 86400 + (r-call * 7 86400)) + valid)) + (if (r-call == (r-call length by2) 2) + (<- by (r-call * by + (r-call as.integer (r-call r-index by2 1)))))) + (<- by (if + (r-call == (r-call length by2) 2) + (r-call as.integer (r-call r-index by2 1)) + 1)))) + (if (r-call ! (r-call + is.numeric by)) + (r-call stop "invalid mode for 'by'")))) + (if (r-call is.na by) + (r-call stop "'by' is NA")) + (if (r-call <= valid 5) + (r-block (<- from (r-call + unclass (r-call as.POSIXct from))) + (if (r-call ! (r-call + is.null length.out)) + (<- res (r-call + seq.int from (*named* by by) + (*named* length.out length.out))) + (r-block (<- to + (r-call unclass (r-call as.POSIXct to))) + (<- res (r-call + (r-call seq.int 0 + (r-call - to from) by) + from)))) + (return (r-call + structure + res (*named* + class (r-call c "POSIXt" + "POSIXct")) + (*named* + tzone tz)))) + (r-block (<- r1 (r-call + as.POSIXlt + from)) + (if (r-call == valid + 7) + (r-block (if (missing + to) + (r-block (<- yr (r-call seq.int (r-call r-aref r1 + (index-in-strlist year (r-call attr + r1 #0#))) + (*named* by by) + (*named* length length.out)))) + (r-block (<- to (r-call as.POSIXlt to)) + (<- yr (r-call seq.int (r-call r-aref r1 + (index-in-strlist year (r-call attr + r1 #0#))) + (r-call r-aref to + (index-in-strlist year (r-call attr to + #0#))) + by)))) + (r-block (<- r1 (r-call r-aref<- r1 + (index-in-strlist year (r-call attr r1 + #0#)) + yr)) + yr) + (r-block (ref= %r:9 (r-call - 1)) (<- r1 (r-call r-aref<- r1 + (index-in-strlist isdst (r-call + attr r1 #0#)) + %r:9)) + %r:9) + (<- res (r-call as.POSIXct r1))) + (if (r-call == + valid 6) + (r-block (if + (missing to) + (r-block (<- mon (r-call seq.int (r-call r-aref r1 + (index-in-strlist mon (r-call attr + r1 #0#))) + (*named* by by) + (*named* length length.out)))) + (r-block (<- to (r-call as.POSIXlt to)) + (<- mon (r-call seq.int (r-call r-aref r1 + (index-in-strlist mon (r-call attr + r1 #0#))) + (r-call + (r-call * 12 + (r-call - (r-call r-aref to + (index-in-strlist + year (r-call + attr to #0#))) + (r-call r-aref r1 + (index-in-strlist + year (r-call attr + r1 #0#))))) + (r-call r-aref to + (index-in-strlist mon (r-call attr + to #0#)))) + by)))) + (r-block (<- r1 (r-call r-aref<- r1 + (index-in-strlist mon (r-call attr r1 + #0#)) + mon)) + mon) + (r-block (ref= %r:10 (r-call - 1)) (<- r1 (r-call r-aref<- r1 + (index-in-strlist isdst (r-call + attr r1 #0#)) + %r:10)) + %r:10) + (<- res (r-call as.POSIXct r1))) + (if (r-call + == valid 8) + (r-block (if (r-call ! (missing to)) + (r-block (<- length.out (r-call + 2 + (r-call floor (r-call / (r-call + - (r-call unclass (r-call as.POSIXct to)) + (r-call unclass (r-call as.POSIXct from))) + 86400)))))) + (r-block (ref= %r:11 (r-call seq.int (r-call r-aref r1 + (index-in-strlist mday + (r-call attr r1 + #0#))) + (*named* by by) + (*named* length length.out))) + (<- r1 (r-call r-aref<- r1 + (index-in-strlist mday (r-call attr r1 + #0#)) + %r:11)) + %r:11) + (r-block (ref= %r:12 (r-call - 1)) + (<- r1 (r-call r-aref<- r1 + (index-in-strlist isdst (r-call attr r1 + #0#)) + %r:12)) + %r:12) + (<- res (r-call as.POSIXct r1)) + (if (r-call ! (missing to)) + (<- res (r-call r-index res + (r-call <= res + (r-call as.POSIXct to))))))))) + (return res))))))) + (<- cut.POSIXt (lambda (x breaks labels start.on.monday right + ...) + (let ((res ()) (maxx ()) (incr ()) (start ()) + (valid ()) (by2 ()) (breaks ()) (x ()) (labels + ()) + (start.on.monday ()) (right ())) + (r-block (when (missing right) + (<- right *r-false*)) + (when (missing start.on.monday) + (<- start.on.monday + *r-true*)) + (when (missing labels) + (<- labels ())) + (if (r-call ! (r-call inherits x + "POSIXt")) + (r-call stop "'x' must be a date-time object")) + (<- x (r-call as.POSIXct x)) + (if (r-call inherits breaks + "POSIXt") + (r-block (<- breaks (r-call + as.POSIXct breaks))) + (if (&& (r-call is.numeric + breaks) + (r-call == (r-call + length breaks) + 1)) + (r-block) + (if (&& (r-call + is.character + breaks) + (r-call == (r-call + length breaks) + 1)) + (r-block (<- by2 (r-call + r-aref (r-call strsplit breaks + " " (*named* fixed *r-true*)) + 1)) + (if (|\|\|| + (r-call > (r-call length by2) 2) (r-call < (r-call length by2) 1)) + (r-call stop "invalid specification of 'breaks'")) + (<- valid (r-call + pmatch (r-call r-index by2 + (r-call length by2)) + (r-call c "secs" + "mins" "hours" "days" + "weeks" "months" "years" + "DSTdays"))) + (if (r-call + is.na valid) + (r-call stop "invalid specification of 'breaks'")) + (<- start (r-call + as.POSIXlt (r-call min x + (*named* na.rm *r-true*)))) + (<- incr 1) + (if (r-call + > valid 1) + (r-block (r-block (<- start (r-call r-aref<- start + (index-in-strlist sec (r-call attr start + #0#)) + 0)) + 0) + (<- incr 59.990000000000002))) + (if (r-call + > valid 2) + (r-block (r-block (<- start (r-call r-aref<- start + (index-in-strlist min (r-call attr start + #0#)) + 0)) + 0) + (<- incr (r-call - 3600 1)))) + (if (r-call + > valid 3) + (r-block (r-block (<- start (r-call r-aref<- start + (index-in-strlist hour (r-call attr start + #0#)) + 0)) + 0) + (<- incr (r-call - 86400 1)))) + (if (r-call + == valid 5) + (r-block (r-block (ref= %r:13 (r-call - (r-call r-aref start + (index-in-strlist mday (r-call + attr start #0#))) + (r-call r-aref start + (index-in-strlist wday (r-call + attr start #0#))))) + (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr start + #0#)) + %r:13)) + %r:13) + (if start.on.monday + (r-block (ref= %r:14 (r-call + (r-call r-aref start + (index-in-strlist mday (r-call + attr start #0#))) + (r-call ifelse (r-call > (r-call + r-aref start (index-in-strlist wday (r-call attr start + #0#))) + 0) + 1 (r-call - 6)))) + (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr + start #0#)) + %r:14)) + %r:14)) + (<- incr (r-call * 7 86400)))) + (if (r-call + == valid 6) + (r-block (r-block (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr start + #0#)) + 1)) + 1) + (<- incr (r-call * 31 86400)))) + (if (r-call + == valid 7) + (r-block (r-block (<- start (r-call r-aref<- start + (index-in-strlist mon (r-call attr start + #0#)) + 0)) + 0) + (r-block (<- start (r-call r-aref<- start + (index-in-strlist mday (r-call attr start + #0#)) + 1)) + 1) + (<- incr (r-call * 366 86400)))) + (if (r-call + == valid 8) + (<- incr (r-call * 25 3600))) + (if (r-call + == (r-call length by2) 2) + (<- incr (r-call * incr + (r-call as.integer (r-call r-index by2 1))))) + (<- maxx (r-call + max x (*named* na.rm *r-true*))) + (<- breaks + (r-call seq.int start + (r-call + maxx incr) breaks)) + (<- breaks + (r-call r-index breaks + (r-call : 1 + (r-call + 1 + (r-call max (r-call which (r-call < breaks maxx)))))))) + (r-call stop "invalid specification of 'breaks'")))) + (<- res (r-call cut (r-call + unclass x) + (r-call unclass + breaks) + (*named* labels + labels) + (*named* right + right) + r-dotdotdot)) + (if (r-call is.null labels) + (r-block (ref= %r:15 (r-call + as.character (r-call r-index breaks + (r-call - (r-call length breaks))))) + (<- res (r-call + levels<- + res %r:15)) + %r:15)) + res)))) + (<- julian (lambda (x ...) + (let () (r-block (r-call UseMethod "julian"))))) + (<- julian.POSIXt (lambda (x origin ...) + (let ((res ()) (origin ())) + (r-block (when (missing origin) + (<- origin (r-call + as.POSIXct + "1970-01-01" + (*named* tz + "GMT")))) + (if (r-call != (r-call length + origin) + 1) + (r-call stop "'origin' must be of length one")) + (<- res (r-call difftime (r-call + as.POSIXct x) + origin (*named* + units "days"))) + (r-call structure res + (*named* origin origin)))))) + (<- weekdays (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "weekdays"))))) + (<- weekdays.POSIXt (lambda (x abbreviate) + (let ((abbreviate ())) + (r-block (when (missing abbreviate) + (<- abbreviate + *r-false*)) + (r-call format x + (r-call ifelse + abbreviate + "%a" + "%A")))))) + (<- months (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "months"))))) + (<- months.POSIXt (lambda (x abbreviate) + (let ((abbreviate ())) + (r-block (when (missing abbreviate) + (<- abbreviate *r-false*)) + (r-call format x + (r-call ifelse + abbreviate "%b" + "%B")))))) + (<- quarters (lambda (x abbreviate) + (let () (r-block (r-call UseMethod "quarters"))))) + (<- quarters.POSIXt (lambda (x ...) + (let ((x ())) + (r-block (<- x (r-call %/% (r-block + (ref= %r:0 (r-call as.POSIXlt x)) (r-call r-aref %r:0 + (index-in-strlist mon (r-call attr + %r:0 #0#)))) + 3)) + (r-call paste "Q" + (r-call + x 1) + (*named* sep "")))))) + (<- trunc.POSIXt (lambda (x units) + (let ((x ()) (units ())) + (r-block (when (missing units) + (<- units (r-call c "secs" + "mins" "hours" "days"))) + (<- units (r-call match.arg + units)) + (<- x (r-call as.POSIXlt x)) + (if (r-call > (r-call length (r-call + r-aref x (index-in-strlist sec (r-call attr x + #0#)))) + 0) + (switch units (*named* secs + (r-block (r-block (ref= %r:16 (r-call trunc (r-call r-aref x + (index-in-strlist sec (r-call + attr x #0#))))) + (<- x (r-call r-aref<- x + (index-in-strlist sec (r-call attr x + #0#)) + %r:16)) + %r:16))) + (*named* mins (r-block + (r-block (<- x (r-call r-aref<- x + (index-in-strlist sec (r-call attr x + #0#)) + 0)) + 0))) + (*named* hours (r-block + (r-block (<- x (r-call r-aref<- x + (index-in-strlist sec (r-call attr x + #0#)) + 0)) + 0) + (r-block (<- x (r-call r-aref<- x + (index-in-strlist min (r-call attr x + #0#)) + 0)) + 0))) + (*named* days (r-block + (r-block (<- x (r-call r-aref<- x + (index-in-strlist sec (r-call attr x + #0#)) + 0)) + 0) + (r-block (<- x (r-call r-aref<- x + (index-in-strlist min (r-call attr x + #0#)) + 0)) + 0) + (r-block (<- x (r-call r-aref<- x + (index-in-strlist hour (r-call attr x + #0#)) + 0)) + 0) + (r-block (ref= %r:17 (r-call - 1)) (<- x (r-call r-aref<- x + (index-in-strlist isdst (r-call + attr x #0#)) + %r:17)) + %r:17))))) + x)))) + (<- round.POSIXt (lambda (x units) + (let ((x ()) (units ())) + (r-block (when (missing units) + (<- units (r-call c "secs" + "mins" "hours" "days"))) + (if (&& (r-call is.numeric + units) + (r-call == units 0)) + (<- units "secs")) + (<- units (r-call match.arg + units)) + (<- x (r-call as.POSIXct x)) + (<- x (r-call + x + (switch units (*named* + secs 0.5) + (*named* mins 30) (*named* hours 1800) (*named* days 43200)))) + (r-call trunc.POSIXt x + (*named* units units)))))) + (<- "[.POSIXlt" (lambda (x ... drop) + (let ((val ()) (drop ())) + (r-block (when (missing drop) + (<- drop *r-true*)) + (<- val (r-call lapply x + "[" r-dotdotdot + (*named* drop + drop))) + (r-block (ref= %r:18 (r-call + attributes x)) + (<- val (r-call + attributes<- + val %r:18)) + %r:18) + val)))) + (<- "[<-.POSIXlt" (lambda (x i value) + (let ((x ()) (cl ()) (value ())) + (r-block (if (r-call ! (r-call + as.logical (r-call + length value))) + (return x)) + (<- value (r-call as.POSIXlt + value)) + (<- cl (r-call oldClass x)) + (r-block (ref= %r:19 (r-block + (<- value (r-call class<- value ())) ())) + (<- x (r-call class<- + x %r:19)) + %r:19) + (for n (r-call names x) + (r-block (ref= %r:20 (r-call + r-aref value n)) + (r-block (ref= + %r:21 (r-call r-index<- (r-call r-aref x n) i %r:20)) + (<- x (r-call r-aref<- x n %r:21)) %r:21) + %r:20)) + (r-block (<- x (r-call class<- + x cl)) + cl) + x)))) + (<- as.data.frame.POSIXlt (lambda (x row.names optional ...) + (let ((value ()) (row.names ()) (optional + ())) + (r-block (when (missing + optional) + (<- optional + *r-false*)) + (when (missing + row.names) + (<- row.names ())) + (<- value (r-call + as.data.frame.POSIXct + (r-call + as.POSIXct x) + row.names + optional + r-dotdotdot)) + (if (r-call ! optional) + (r-block (ref= + %r:22 (r-call r-aref (r-call deparse (substitute x)) 1)) + (<- value (r-call names<- value %r:22)) %r:22)) + value)))) + (<- rep.POSIXct (lambda (x ...) + (let ((y ())) + (r-block (<- y (r-call NextMethod)) + (r-call structure y + (*named* class (r-call + c "POSIXt" "POSIXct")) + (*named* tzone (r-call + attr x "tzone"))))))) + (<- rep.POSIXlt (lambda (x ...) + (let ((y ())) + (r-block (<- y (r-call lapply x rep + r-dotdotdot)) + (r-block (ref= %r:23 (r-call + attributes x)) + (<- y (r-call + attributes<- y + %r:23)) + %r:23) + y)))) + (<- diff.POSIXt (lambda (x lag differences ...) + (let ((i1 ()) (xlen ()) (r ()) (ismat ()) (lag + ()) + (differences ())) + (r-block (when (missing differences) + (<- differences 1)) + (when (missing lag) + (<- lag 1)) + (<- ismat (r-call is.matrix x)) + (<- r (if (r-call inherits x + "POSIXlt") + (r-call as.POSIXct x) + x)) + (<- xlen (if ismat + (r-call r-index (r-call + dim x) + 1) + (r-call length r))) + (if (|\|\|| (r-call > (r-call + length lag) + 1) + (r-call > (r-call + length differences) + 1) + (r-call < lag 1) + (r-call < + differences + 1)) + (r-call stop "'lag' and 'differences' must be integers >= 1")) + (if (r-call >= (r-call * lag + differences) + xlen) + (return (r-call structure (r-call + numeric 0) + (*named* + class "difftime") + (*named* + units "secs")))) + (<- i1 (r-call : (r-call - 1) + (r-call - lag))) + (if ismat + (for i (r-call : 1 + differences) + (<- r (r-call - (r-call + r-index r i1 *r-missing* + (*named* drop *r-false*)) + (r-call + r-index r + (r-call : + (r-call - (r-call nrow r)) (r-call - (r-call + (r-call - (r-call nrow r) lag) + 1))) + *r-missing* + (*named* + drop *r-false*))))) + (for i (r-call : 1 + differences) + (<- r (r-call - (r-call + r-index r i1) + (r-call + r-index r + (r-call : + (r-call - (r-call length r)) (r-call - (r-call + (r-call - (r-call length r) + lag) + 1)))))))) + r)))) + (<- duplicated.POSIXlt (lambda (x incomparables ...) + (let ((x ()) (incomparables ())) + (r-block (when (missing + incomparables) + (<- incomparables + *r-false*)) + (<- x (r-call as.POSIXct + x)) + (r-call NextMethod "duplicated" + x))))) + (<- unique.POSIXlt (lambda (x incomparables ...) + (let ((incomparables ())) + (r-block (when (missing incomparables) + (<- incomparables + *r-false*)) + (r-call r-index x + (r-call ! (r-call + duplicated x incomparables r-dotdotdot))))))) + (<- sort.POSIXlt (lambda (x decreasing na.last ...) + (let ((decreasing ()) (na.last ())) + (r-block (when (missing na.last) + (<- na.last NA)) + (when (missing decreasing) + (<- decreasing *r-false*)) + (r-call r-index x + (r-call order (r-call + as.POSIXct x) + (*named* + na.last + na.last) + (*named* + decreasing + decreasing)))))))) diff --git a/femtolisp/ast/rpasses.lsp b/femtolisp/ast/rpasses.lsp index d10eaef..ae46993 100644 --- a/femtolisp/ast/rpasses.lsp +++ b/femtolisp/ast/rpasses.lsp @@ -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) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 4587f91..f1172dd 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -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 }, diff --git a/femtolisp/color.lsp b/femtolisp/color.lsp index 69542a5..f1b9a50 100644 --- a/femtolisp/color.lsp +++ b/femtolisp/color.lsp @@ -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)) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 02dd64d..fb015e2 100644 --- a/femtolisp/cps.lsp +++ b/femtolisp/cps.lsp @@ -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))))) |# diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index eca0cf5..803383c 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -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])); } diff --git a/femtolisp/equal.c b/femtolisp/equal.c index 4c225b0..9f1f748 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -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); } /* diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index f817ebd..23902d0 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -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"); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index a7fbebe..f64301b 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -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); diff --git a/femtolisp/opaque_type_template.c b/femtolisp/opaque_type_template.c new file mode 100644 index 0000000..246f97b --- /dev/null +++ b/femtolisp/opaque_type_template.c @@ -0,0 +1,63 @@ +#include +#include +#include +#include +#include +#include +#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); +} diff --git a/femtolisp/perf.lsp b/femtolisp/perf.lsp index f009163..084024d 100644 --- a/femtolisp/perf.lsp +++ b/femtolisp/perf.lsp @@ -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 "..") diff --git a/femtolisp/pisum.lsp b/femtolisp/pisum.lsp index f3cf897..2cb7f6b 100644 --- a/femtolisp/pisum.lsp +++ b/femtolisp/pisum.lsp @@ -1,4 +1,4 @@ -(defun pisum () +(define (pisum) (dotimes (j 500) ((label sumloop (lambda (i sum) diff --git a/femtolisp/print.c b/femtolisp/print.c index 37ed69f..acdd455 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -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; diff --git a/femtolisp/read.c b/femtolisp/read.c index 96c52ac..6c06c3c 100644 --- a/femtolisp/read.c +++ b/femtolisp/read.c @@ -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"); @@ -465,6 +459,7 @@ static value_t do_read_sexpr(ios_t *f, value_t label) value_t v, sym, oldtokval, *head; value_t *pv; u_int32_t t; + char c; t = peek(f); take(); @@ -511,8 +506,18 @@ static value_t do_read_sexpr(ios_t *f, value_t label) read_list(f, &Stack[SP-1], label); return POP(); case TOK_SHARPSYM: - // constructor notation sym = tokval; + if (sym == tsym || sym == Tsym) + return FL_T; + else if (sym == fsym || sym == Fsym) + return FL_F; + // constructor notation + c = nextchar(f); + if (c != '(') { + take(); + lerror(ParseError, "read: expected argument list for %s", + symbol_name(tokval)); + } PUSH(NIL); read_list(f, &Stack[SP-1], UNBOUND); v = POP(); diff --git a/femtolisp/stream.c b/femtolisp/stream.c index 171471d..a2ceda5 100644 --- a/femtolisp/stream.c +++ b/femtolisp/stream.c @@ -31,8 +31,8 @@ int isstream(value_t v) value_t fl_streamp(value_t *args, uint32_t nargs) { - argcount("streamp", nargs, 1); - return isstream(args[0]) ? T : NIL; + argcount("stream?", nargs, 1); + return isstream(args[0]) ? FL_T : FL_F; } static ios_t *tostream(value_t v, char *fname) @@ -43,7 +43,7 @@ static ios_t *tostream(value_t v, char *fname) } static builtinspec_t streamfunc_info[] = { - { "streamp", fl_streamp }, + { "stream?", fl_streamp }, { NULL, NULL } }; diff --git a/femtolisp/string.c b/femtolisp/string.c index cf9751a..13e9ab2 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -37,8 +37,8 @@ static value_t print_to_string(value_t v, int princ) value_t fl_stringp(value_t *args, u_int32_t nargs) { - argcount("stringp", nargs, 1); - return isstring(args[0]) ? T : NIL; + argcount("string?", nargs, 1); + return isstring(args[0]) ? FL_T : FL_F; } value_t fl_string_length(value_t *args, u_int32_t nargs) @@ -84,7 +84,7 @@ value_t fl_string_decode(value_t *args, u_int32_t nargs) { int term=0; if (nargs == 2) { - term = (POP() != NIL); + term = (POP() != FL_F); nargs--; } argcount("string.decode", nargs, 1); @@ -254,7 +254,7 @@ static value_t mem_find_byte(char *s, char c, size_t start, size_t len) { char *p = memchr(s+start, c, len-start); if (p == NULL) - return NIL; + return FL_F; return size_wrap((size_t)(p - s)); } @@ -293,7 +293,7 @@ value_t fl_string_find(value_t *args, u_int32_t nargs) type_error("string.find", "string", args[1]); } if (needlesz > len-start) - return NIL; + return FL_F; else if (needlesz == 1) return mem_find_byte(s, needle[0], start, len); else if (needlesz == 0) @@ -305,7 +305,7 @@ value_t fl_string_find(value_t *args, u_int32_t nargs) return size_wrap(i); } } - return NIL; + return FL_F; } value_t fl_string_inc(value_t *args, u_int32_t nargs) @@ -349,7 +349,7 @@ value_t fl_string_dec(value_t *args, u_int32_t nargs) static builtinspec_t stringfunc_info[] = { { "string", fl_string }, - { "stringp", fl_stringp }, + { "string?", fl_stringp }, { "string.length", fl_string_length }, { "string.split", fl_string_split }, { "string.sub", fl_string_sub }, diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index 514f3d5..c828e12 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -1,56 +1,70 @@ +; -*- scheme -*- ; femtoLisp standard library ; by Jeff Bezanson (C) 2009 ; Distributed under the BSD License +(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. -(setq f-body (lambda (e) +(set! f-body (lambda (e) (cond ((atom e) e) ((eq (cdr e) ()) (car e)) - (T (cons 'progn e))))) + (T (cons 'begin e))))) -(set-syntax 'defmacro - (lambda (name args . body) - (list 'set-syntax (list 'quote name) - (list 'lambda args (f-body body))))) +(set-syntax! 'define-macro + (lambda (form . body) + (list 'set-syntax! (list 'quote (car form)) + (list 'lambda (cdr form) (f-body body))))) -(defmacro label (name fn) - (list (list 'lambda (list name) (list 'setq name fn)) nil)) +(define-macro (label name fn) + (list (list 'lambda (list name) (list 'set! name fn)) #f)) -; support both CL defun and Scheme-style define -(defmacro defun (name args . body) - (list 'setq name (list 'lambda args (f-body body)))) +(define-macro (define form . body) + (if (symbolp form) + (list 'set! form (car body)) + (list 'set! (car form) (list 'lambda (cdr form) (f-body body))))) -(defmacro define (name . body) - (if (symbolp name) - (list 'setq name (car body)) - (cons 'defun (cons (car name) (cons (cdr name) body))))) +(define (set s v) (eval (list 'set! s (list 'quote v)))) -(defun set (s v) (eval (list 'setq s (list 'quote v)))) +(define (identity x) x) -(defun identity (x) x) -(setq null not) - -(defun map (f lst) +(define (map f lst) (if (atom lst) lst - (cons (f (car lst)) (map f (cdr lst))))) + (cons (f (car lst)) (map f (cdr lst))))) -(defmacro let (binds . body) +(define-macro (let binds . body) (cons (list 'lambda (map (lambda (c) (if (consp c) (car c) c)) binds) (f-body body)) - (map (lambda (c) (if (consp c) (cadr c) nil)) binds))) + (map (lambda (c) (if (consp c) (cadr c) #f)) binds))) -(defun nconc lsts +(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))))))) + (rplacd (last (car lsts)) + (apply nconc (cdr lsts))))))) -(defun append lsts +(define (append . lsts) (cond ((null lsts) ()) ((null (cdr lsts)) (car lsts)) (T ((label append2 (lambda (l d) @@ -59,43 +73,61 @@ (append2 (cdr l) d))))) (car lsts) (apply append (cdr lsts)))))) -(defun member (item lst) - (cond ((atom lst) ()) - ((equal (car lst) item) lst) - (T (member item (cdr lst))))) +(define (member item 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))))) +(define (memv item lst) + (cond ((atom lst) #f) + ((eqv (car lst) item) lst) + (T (memv item (cdr lst))))) -(defun macrocallp (e) (and (symbolp (car e)) - (symbol-syntax (car e)))) +(define (assoc item 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))))) -(defun functionp (x) +(define (macrocall? e) (and (symbolp (car e)) + (symbol-syntax (car e)))) + +(define (function? x) (or (builtinp x) (and (consp x) (eq (car x) 'lambda)))) +(define procedure? function?) -(defun macroexpand-1 (e) +(define (macroexpand-1 e) (if (atom e) e - (let ((f (macrocallp e))) - (if f (apply f (cdr e)) - e)))) + (let ((f (macrocall? e))) + (if f (apply f (cdr e)) + e)))) ; convert to proper list, i.e. remove "dots", and append -(defun append.2 (l tail) +(define (append.2 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))) -;(setq *special-forms* '(quote cond if and or while lambda trycatch -; setq progn)) +;(set! *special-forms* '(quote cond if and or while lambda trycatch +; set! begin)) -(defun macroexpand (e) +(define (macroexpand e) ((label mexpand (lambda (e env f) - (progn + (begin (while (and (consp e) (not (member (car e) env)) - (setq f (macrocallp e))) - (setq e (apply f (cdr e)))) + (set! f (macrocall? e))) + (set! e (apply f (cdr e)))) (cond ((and (consp e) (not (eq (car e) 'quote))) (let ((newenv @@ -103,28 +135,26 @@ (consp (cdr e))) (append.2 (cadr e) env) env))) - (map (lambda (x) (mexpand x newenv nil)) e))) - ;((and (symbolp e) (constantp e)) (eval e)) + (map (lambda (x) (mexpand x newenv ())) e))) + ;((and (symbolp e) (constant? e)) (eval e)) ;((and (symbolp e) ; (not (member e *special-forms*)) ; (not (member e env))) (cons '%top e)) (T e))))) - e nil nil)) + e () ())) -; uncomment this to macroexpand functions at definition time. -; makes typical code ~25% faster, but only works for defun expressions -; at the top level. -(defmacro defun (name args . body) - (list 'setq name (macroexpand (list 'lambda args (f-body body))))) +(define-macro (define form . body) + (if (symbolp form) + (list 'set! form (car body)) + (list 'set! (car form) + (macroexpand (list 'lambda (cdr form) (f-body body)))))) +(define-macro (define-macro form . body) + (list 'set-syntax! (list 'quote (car form)) + (macroexpand (list 'lambda (cdr form) (f-body body))))) +(define macroexpand (macroexpand macroexpand)) -; same thing for macros. enabled by default because macros are usually -; defined at the top level. -(defmacro defmacro (name args . body) - (list 'set-syntax (list 'quote name) - (macroexpand (list 'lambda args (f-body body))))) - -(setq = equal) -(setq eql equal) +(define = equal) +(define eql eqv) (define (/= a b) (not (equal a b))) (define != /=) (define (> a b) (< b a)) @@ -134,11 +164,7 @@ (define (1- n) (- n 1)) (define (mod x y) (- x (* (/ x y) y))) (define (abs x) (if (< x 0) (- x) x)) -(setq K prog1) ; K combinator ;) -(define (funcall f . args) (apply f args)) -(define (symbol-value sym) (eval sym)) -(define symbol-function symbol-value) -(define (terpri) (princ "\n") nil) +(define K prog1) ; K combinator ;) (define (caar x) (car (car x))) (define (cdar x) (cdr (car x))) @@ -153,51 +179,52 @@ (define (cddar x) (cdr (cdr (car x)))) (define (cdddr x) (cdr (cdr (cdr x)))) -(defun every (pred lst) +(define (every pred lst) (or (atom lst) (and (pred (car lst)) (every pred (cdr lst))))) -(defun any (pred lst) +(define (any pred lst) (and (consp lst) (or (pred (car lst)) (any pred (cdr lst))))) -(defun listp (a) (or (eq a ()) (consp a))) +(define (listp a) (or (null a) (consp a))) +(define (list? a) (or (null a) (and (pair? a) (list? (cdr a))))) -(defun nthcdr (lst n) +(define (nthcdr lst n) (if (<= n 0) lst - (nthcdr (cdr lst) (- n 1)))) + (nthcdr (cdr lst) (- n 1)))) -(defun list-ref (lst n) +(define (list-ref lst n) (car (nthcdr lst n))) -(defun list* l +(define (list* . l) (if (atom (cdr l)) (car l) - (cons (car l) (apply list* (cdr l))))) + (cons (car l) (apply list* (cdr l))))) -(defun nlist* l +(define (nlist* . l) (if (atom (cdr l)) (car l) - (rplacd l (apply nlist* (cdr l))))) + (rplacd l (apply nlist* (cdr l))))) -(defun lastcdr (l) +(define (lastcdr l) (if (atom l) l - (lastcdr (cdr l)))) + (lastcdr (cdr l)))) -(defun last (l) +(define (last l) (cond ((atom l) l) ((atom (cdr l)) l) (T (last (cdr l))))) -(defun map! (f lst) +(define (map! f lst) (prog1 lst - (while (consp lst) - (rplaca lst (f (car lst))) - (setq lst (cdr lst))))) + (while (consp lst) + (rplaca lst (f (car lst))) + (set! lst (cdr lst))))) -(defun mapcar (f . lsts) +(define (mapcar f . lsts) ((label mapcar- (lambda (lsts) (cond ((null lsts) (f)) @@ -206,18 +233,18 @@ (mapcar- (map cdr lsts))))))) lsts)) -(defun transpose (M) (apply mapcar (cons list M))) +(define (transpose M) (apply mapcar (cons list M))) -(defun filter (pred lst) (filter- pred lst nil)) -(defun filter- (pred lst accum) +(define (filter pred lst) (filter- pred lst ())) +(define (filter- pred lst accum) (cond ((null lst) accum) ((pred (car lst)) (filter- pred (cdr lst) (cons (car lst) accum))) (T (filter- pred (cdr lst) accum)))) -(defun separate (pred lst) (separate- pred lst nil nil)) -(defun separate- (pred lst yes no) +(define (separate pred lst) (separate- pred lst () ())) +(define (separate- pred lst yes no) (cond ((null lst) (cons yes no)) ((pred (car lst)) (separate- pred (cdr lst) (cons (car lst) yes) no)) @@ -232,11 +259,7 @@ (if (null lst) zero (foldl f (f (car lst) zero) (cdr lst)))) -(define (reverse lst) (foldl cons nil lst)) - -(defun reduce (f zero lst) - (if (null lst) zero - (reduce f (f zero (car lst)) (cdr lst)))) +(define (reverse lst) (foldl cons () lst)) (define (copy-list l) (if (atom l) l @@ -248,80 +271,80 @@ (copy-tree (cdr l))))) (define (nreverse l) - (let ((prev nil)) + (let ((prev ())) (while (consp l) - (setq l (prog1 (cdr l) - (rplacd l (prog1 prev - (setq prev l)))))) + (set! l (prog1 (cdr l) + (rplacd l (prog1 prev + (set! prev l)))))) prev)) -(defmacro let* (binds . body) +(define-macro (let* binds . body) (cons (list 'lambda (map car binds) - (cons 'progn - (nconc (map (lambda (b) (cons 'setq b)) binds) + (cons 'begin + (nconc (map (lambda (b) (cons 'set! b)) binds) body))) - (map (lambda (x) nil) binds))) + (map (lambda (x) #f) binds))) -(defmacro labels (binds . body) +(define-macro (labels binds . body) (cons (list 'lambda (map car binds) - (cons 'progn + (cons 'begin (nconc (map (lambda (b) - (list 'setq (car b) (cons 'lambda (cdr b)))) + (list 'set! (car b) (cons 'lambda (cdr b)))) binds) body))) - (map (lambda (x) nil) binds))) + (map (lambda (x) #f) binds))) -(defmacro when (c . body) (list 'if c (f-body body) nil)) -(defmacro unless (c . body) (list 'if c nil (f-body body))) +(define-macro (when c . body) (list 'if c (f-body body) #f)) +(define-macro (unless c . body) (list 'if c #f (f-body body))) -(defmacro dotimes (var . body) +(define-macro (dotimes var . body) (let ((v (car var)) (cnt (cadr var))) `(for 0 (- ,cnt 1) (lambda (,v) ,(f-body body))))) -(defun map-int (f n) +(define (map-int f n) (if (<= n 0) () - (let ((first (cons (f 0) nil)) - (acc nil)) - (setq acc first) + (let ((first (cons (f 0) ())) + (acc ())) + (set! acc first) (for 1 (- n 1) (lambda (i) - (progn (rplacd acc (cons (f i) nil)) - (setq acc (cdr acc))))) + (begin (rplacd acc (cons (f i) ())) + (set! acc (cdr acc))))) first))) -(defun iota (n) (map-int identity n)) +(define (iota n) (map-int identity n)) (define ι iota) -(defun error args (raise (cons 'error args))) +(define (error . args) (raise (cons 'error args))) -(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value))) -(defmacro catch (tag expr) +(define-macro (throw tag value) `(raise (list 'thrown-value ,tag ,value))) +(define-macro (catch tag expr) (let ((e (gensym))) `(trycatch ,expr (lambda (,e) (if (and (consp ,e) (eq (car ,e) 'thrown-value) (eq (cadr ,e) ,tag)) (caddr ,e) - (raise ,e)))))) + (raise ,e)))))) -(defmacro unwind-protect (expr finally) +(define-macro (unwind-protect expr finally) (let ((e (gensym))) `(prog1 (trycatch ,expr - (lambda (,e) (progn ,finally (raise ,e)))) - ,finally))) + (lambda (,e) (begin ,finally (raise ,e)))) + ,finally))) ; (try expr ; (catch (type-error e) . exprs) ; (catch (io-error e) . exprs) ; (catch (e) . exprs) ; (finally . exprs)) -(defmacro try (expr . forms) +(define-macro (try expr . forms) (let* ((e (gensym)) (reraised (gensym)) - (final (f-body (cdr (or (assoc 'finally forms) '(()))))) + (final (f-body (cdr (or (assq 'finally forms) '(()))))) (catches (filter (lambda (f) (eq (car f) 'catch)) forms)) (catchblock `(cond ,.(map (lambda (catc) @@ -337,7 +360,7 @@ (eq (car ,e) ',extype))) T); (catch (e) ...), match anything - (let ((,var ,e)) (progn ,@todo))))) + (let ((,var ,e)) (begin ,@todo))))) catches) (T (raise ,e))))) ; no matches, reraise (if final @@ -347,12 +370,12 @@ (lambda (,e) (trycatch ,catchblock (lambda (,reraised) - (progn ,final + (begin ,final (raise ,reraised)))))) ,final) ; finally only; same as unwind-protect `(prog1 (trycatch ,expr (lambda (,e) - (progn ,final (raise ,e)))) + (begin ,final (raise ,e)))) ,final)) ; catch, no finally `(trycatch ,expr (lambda (,e) ,catchblock))))) @@ -360,7 +383,7 @@ ; setf ; expands (setf (place x ...) v) to (mutator (f x ...) v) ; (mutator (identity x ...) v) is interpreted as (mutator x ... v) -(setq *setf-place-list* +(set! *setf-place-list* ; place mutator f '((car rplaca identity) (cdr rplacd identity) @@ -379,60 +402,58 @@ (list-ref rplaca nthcdr) (get put identity) (aref aset identity) - (symbol-function set identity) - (symbol-value set identity) - (symbol-syntax set-syntax identity))) + (symbol-syntax set-syntax! identity))) -(defun setf-place-mutator (place val) +(define (setf-place-mutator place val) (if (symbolp place) - (list 'setq place val) - (let ((mutator (assoc (car place) *setf-place-list*))) + (list 'set! place val) + (let ((mutator (assq (car place) *setf-place-list*))) (if (null mutator) - (error '|setf: unknown place | (car place)) - (if (eq (caddr mutator) 'identity) - (cons (cadr mutator) (append (cdr place) (list val))) - (list (cadr mutator) - (cons (caddr mutator) (cdr place)) - val)))))) + (error "setf: unknown place " (car place)) + (if (eq (caddr mutator) 'identity) + (cons (cadr mutator) (append (cdr place) (list val))) + (list (cadr mutator) + (cons (caddr mutator) (cdr place)) + val)))))) -(defmacro setf args +(define-macro (setf . args) (f-body ((label setf- (lambda (args) (if (null args) - nil + () (cons (setf-place-mutator (car args) (cadr args)) (setf- (cddr args)))))) args))) -(defun revappend (l1 l2) (nconc (reverse l1) l2)) -(defun nreconc (l1 l2) (nconc (nreverse l1) l2)) +(define (revappend l1 l2) (nconc (reverse l1) l2)) +(define (nreconc l1 l2) (nconc (nreverse l1) l2)) -(defun list-to-vector (l) (apply vector l)) -(defun vector-to-list (v) +(define (list-to-vector l) (apply vector l)) +(define (vector-to-list v) (let ((n (length v)) - (l nil)) + (l ())) (for 1 n (lambda (i) - (setq l (cons (aref v (- n i)) l)))) + (set! l (cons (aref v (- n i)) l)))) l)) -(defun self-evaluating-p (x) +(define (self-evaluating? x) (or (and (atom x) (not (symbolp x))) - (and (constantp x) + (and (constant? x) (eq x (eval x))))) ; backquote -(defmacro backquote (x) (bq-process x)) +(define-macro (backquote x) (bq-process x)) -(defun splice-form-p (x) +(define (splice-form? x) (or (and (consp x) (or (eq (car x) '*comma-at*) (eq (car x) '*comma-dot*))) (eq x '*comma*))) -(defun bq-process (x) - (cond ((self-evaluating-p x) +(define (bq-process x) + (cond ((self-evaluating? x) (if (vectorp x) (let ((body (bq-process (vector-to-list x)))) (if (eq (car body) 'list) @@ -442,7 +463,7 @@ ((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-p x)) + ((not (any splice-form? x)) (let ((lc (lastcdr x)) (forms (map bq-bracket1 x))) (if (null lc) @@ -451,8 +472,8 @@ (T (let ((p x) (q ())) (while (and (consp p) (not (eq (car p) '*comma*))) - (setq q (cons (bq-bracket (car p)) q)) - (setq p (cdr p))) + (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)) @@ -461,7 +482,7 @@ (car forms) (cons 'nconc forms))))))) -(defun bq-bracket (x) +(define (bq-bracket 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))) @@ -469,21 +490,23 @@ (T (list list (bq-process x))))) ; bracket without splicing -(defun bq-bracket1 (x) +(define (bq-bracket1 x) (if (and (consp x) (eq (car x) '*comma*)) (cadr x) - (bq-process x))) + (bq-process x))) -(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr)))) +(define-macro (assert expr) `(if ,expr T (raise '(assert-failed ,expr)))) -(defmacro time (expr) +(define-macro (time expr) (let ((t0 (gensym))) `(let ((,t0 (time.now))) (prog1 - ,expr - (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) + ,expr + (princ "Elapsed time: " (- (time.now) ,t0) " seconds\n"))))) -(defun vector.map (f v) +(define (display x) (princ x) (princ "\n")) + +(define (vector.map f v) (let* ((n (length v)) (nv (vector.alloc n))) (for 0 (- n 1) @@ -491,16 +514,16 @@ (aset nv i (f (aref v i))))) nv)) -(defun table.pairs (t) +(define (table.pairs t) (table.foldl (lambda (k v z) (cons (cons k v) z)) () t)) -(defun table.keys (t) +(define (table.keys t) (table.foldl (lambda (k v z) (cons k z)) () t)) -(defun table.values (t) +(define (table.values t) (table.foldl (lambda (k v z) (cons v z)) () t)) -(defun table.clone (t) +(define (table.clone t) (let ((nt (table))) (table.foldl (lambda (k v z) (put nt k v)) () t) diff --git a/femtolisp/table.c b/femtolisp/table.c index d856aa8..751cca1 100644 --- a/femtolisp/table.c +++ b/femtolisp/table.c @@ -70,8 +70,8 @@ int ishashtable(value_t v) value_t fl_tablep(value_t *args, uint32_t nargs) { - argcount("tablep", nargs, 1); - return ishashtable(args[0]) ? T : NIL; + argcount("table?", nargs, 1); + return ishashtable(args[0]) ? FL_T : FL_F; } static htable_t *totable(value_t v, char *fname) @@ -139,7 +139,7 @@ value_t fl_table_has(value_t *args, uint32_t nargs) { argcount("has", nargs, 2); htable_t *h = totable(args[0], "has"); - return equalhash_has(h, (void*)args[1]) ? T : NIL; + return equalhash_has(h, (void*)args[1]) ? FL_T : FL_F; } // (del table key) @@ -177,7 +177,7 @@ value_t fl_table_foldl(value_t *args, uint32_t nargs) static builtinspec_t tablefunc_info[] = { { "table", fl_table }, - { "tablep", fl_tablep }, + { "table?", fl_tablep }, { "put", fl_table_put }, { "get", fl_table_get }, { "has", fl_table_has }, diff --git a/femtolisp/tcolor.lsp b/femtolisp/tcolor.lsp index ba35fc9..bd11d18 100644 --- a/femtolisp/tcolor.lsp +++ b/femtolisp/tcolor.lsp @@ -1,11 +1,12 @@ +; -*- scheme -*- ; color for performance (load "color.lsp") ; 100x color 5 queens -(setq Q (generate-5x5-pairs)) -(defun ct () - (setq C (color-pairs Q '(a b c d e))) +(define Q (generate-5x5-pairs)) +(define (ct) + (set! C (color-pairs Q '(a b c d e))) (dotimes (n 99) (color-pairs Q '(a b c d e)))) (time (ct)) (assert (equal C '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) diff --git a/femtolisp/test.lsp b/femtolisp/test.lsp index 7b936b5..bea51a5 100644 --- a/femtolisp/test.lsp +++ b/femtolisp/test.lsp @@ -1,15 +1,17 @@ +; -*- scheme -*- + ; make label self-evaluating, but evaluating the lambda in the process ;(defmacro labl (name f) ; (list list ''labl (list 'quote name) f)) -(defmacro labl (name f) - `(let (,name) (setq ,name ,f))) +(define-macro (labl name f) + `(let (,name) (set! ,name ,f))) ;(define (reverse lst) ; ((label rev-help (lambda (lst result) ; (if (null lst) result ; (rev-help (cdr lst) (cons (car lst) result))))) -; lst nil)) +; lst ())) (define (append- . lsts) ((label append-h @@ -28,20 +30,20 @@ (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) ;(princ (time (fib 34)) "\n") ;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8)) -;(dotimes (i 40000) (append '(a b) '(1 2 3 4) nil '(c) nil '(5 6))) +;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6))) ;(dotimes (i 80000) (list 1 2 3 4 5)) -;(setq a (map-int identity 10000)) -;(dotimes (i 200) (rfoldl cons nil a)) +;(set! a (map-int identity 10000)) +;(dotimes (i 200) (rfoldl cons () a)) ; iterative filter -(defun ifilter (pred lst) +(define (ifilter pred lst) ((label f (lambda (accum lst) (cond ((null lst) (nreverse accum)) ((not (pred (car lst))) (f accum (cdr lst))) (T (f (cons (car lst) accum) (cdr lst)))))) - nil lst)) + () lst)) -(defun sort (l) +(define (sort l) (if (or (null l) (null (cdr l))) l (let* ((piv (car l)) (halves (separate (lambda (x) (< x piv)) (cdr l)))) @@ -49,29 +51,29 @@ (list piv) (sort (cdr halves)))))) -(defmacro dotimes (var . body) +(define-macro (dotimes var . body) (let ((v (car var)) (cnt (cadr var))) `(let ((,v 0)) (while (< ,v ,cnt) (prog1 ,(f-body body) - (setq ,v (+ ,v 1))))))) + (set! ,v (+ ,v 1))))))) -(defun map-int (f n) +(define (map-int f n) (if (<= n 0) () - (let ((first (cons (f 0) nil))) - ((label map-int- - (lambda (acc i n) - (if (= i n) - first - (progn (rplacd acc (cons (f i) nil)) - (map-int- (cdr acc) (+ i 1) n))))) - first 1 n)))) + (let ((first (cons (f 0) ()))) + ((label map-int- + (lambda (acc i n) + (if (= i n) + first + (begin (rplacd acc (cons (f i) ())) + (map-int- (cdr acc) (+ i 1) n))))) + first 1 n)))) -(defmacro labl (name fn) - `((lambda (,name) (setq ,name ,fn)) nil)) +(define-macro (labl name fn) + `((lambda (,name) (set! ,name ,fn)) ())) (define (square x) (* x x)) (define (evenp x) (= x (* (/ x 2) 2))) @@ -88,43 +90,43 @@ (T (gcd b (- a b))))) ; like eval-when-compile -(defmacro literal (expr) +(define-macro (literal expr) (let ((v (eval expr))) - (if (self-evaluating-p v) v (list quote v)))) + (if (self-evaluating? v) v (list quote v)))) -(defun cardepth (l) +(define (cardepth l) (if (atom l) 0 - (+ 1 (cardepth (car l))))) + (+ 1 (cardepth (car l))))) -(defun nestlist (f zero n) +(define (nestlist f zero n) (if (<= n 0) () - (cons zero (nestlist f (f zero) (- n 1))))) + (cons zero (nestlist f (f zero) (- n 1))))) -(defun mapl (f . lsts) +(define (mapl f . lsts) ((label mapl- (lambda (lsts) (if (null (car lsts)) () - (progn (apply f lsts) (mapl- (map cdr lsts)))))) + (begin (apply f lsts) (mapl- (map cdr lsts)))))) lsts)) ; test to see if a symbol begins with : -(defun keywordp (s) +(define (keywordp s) (and (>= s '|:|) (<= s '|:~|))) ; swap the cars and cdrs of every cons in a structure -(defun swapad (c) +(define (swapad c) (if (atom c) c - (rplacd c (K (swapad (car c)) - (rplaca c (swapad (cdr c))))))) + (rplacd c (K (swapad (car c)) + (rplaca c (swapad (cdr c))))))) -(defun without (x l) +(define (without x l) (filter (lambda (e) (not (eq e x))) l)) -(defun conscount (c) +(define (conscount c) (if (consp c) (+ 1 (conscount (car c)) (conscount (cdr c))) - 0)) + 0)) ; _ Welcome to ; (_ _ _ |_ _ | . _ _ 2 @@ -135,12 +137,12 @@ ;| (/_||||_()|_|_\|) ; | -(defmacro while- (test . forms) +(define-macro (while- test . forms) `((label -loop- (lambda () (if ,test - (progn ,@forms + (begin ,@forms (-loop-)) - nil))))) + ()))))) ; this would be a cool use of thunking to handle 'finally' clauses, but ; this code doesn't work in the case where the user manually re-raises @@ -150,8 +152,8 @@ ; (catch (TypeError e) . exprs) ; (catch (IOError e) . exprs) ; (finally . exprs)) -(defmacro try (expr . forms) - (let ((final (f-body (cdr (or (assoc 'finally forms) '(()))))) +(define-macro (try expr . forms) + (let ((final (f-body (cdr (or (assq 'finally forms) '(()))))) (body (foldr ; create a function to check for and handle one exception ; type, and pass off control to the next when no match @@ -167,7 +169,7 @@ (,next ,var))))) ; default function; no matches so re-raise - '(lambda (e) (progn (*_try_finally_thunk_*) (raise e))) + '(lambda (e) (begin (*_try_finally_thunk_*) (raise e))) ; make list of catch forms (filter (lambda (f) (eq (car f) 'catch)) forms)))) @@ -175,10 +177,6 @@ (prog1 (attempt ,expr ,body) (*_try_finally_thunk_*))))) -(defun map (f lst) - (if (atom lst) lst - (cons (funcall f (car lst)) (map f (cdr lst))))) - (define Y (lambda (f) ((lambda (h) @@ -191,56 +189,39 @@ (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))))) -(defmacro debug () - (let ((g (gensym))) - `(progn (princ "Debug REPL:\n") - (let ((,g (read))) - (while (not (eq ,g 'quit)) - (prog1 - (print (trycatch (apply '(macro x x) ,g) - identity)) - (setq ,g (read)))))))) - ;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) ))) ;(tt) ;(tt) ;(tt) -(let ((g (gensym))) - (defmacro delay (expr) - `(let ((,g ',g)) - (lambda () (if (eq ,g ',g) (setq ,g ,expr) ,g))))) - -(defun force (p) (p)) - -(defmacro accumulate-while (cnd what . body) +(define-macro (accumulate-while cnd what . body) (let ((first (gensym)) (acc (gensym))) - `(let ((,first nil) - (,acc (list nil))) - (setq ,first ,acc) + `(let ((,first ()) + (,acc (list ()))) + (set! ,first ,acc) (while ,cnd - (progn (setq ,acc - (cdr (rplacd ,acc (cons ,what nil)))) - ,@body)) + (begin (set! ,acc + (cdr (rplacd ,acc (cons ,what ())))) + ,@body)) (cdr ,first)))) -(defmacro accumulate-for (var lo hi what . body) +(define-macro (accumulate-for var lo hi what . body) (let ((first (gensym)) (acc (gensym))) - `(let ((,first nil) - (,acc (list nil))) - (setq ,first ,acc) + `(let ((,first ()) + (,acc (list ()))) + (set! ,first ,acc) (for ,lo ,hi (lambda (,var) - (progn (setq ,acc - (cdr (rplacd ,acc (cons ,what nil)))) + (begin (set! ,acc + (cdr (rplacd ,acc (cons ,what ())))) ,@body))) (cdr ,first)))) -(defun map-indexed (f lst) +(define (map-indexed f lst) (if (atom lst) lst (let ((i 0)) (accumulate-while (consp lst) (f (car lst) i) - (progn (setq lst (cdr lst)) - (setq i (1+ i))))))) + (begin (set! lst (cdr lst)) + (set! i (1+ i))))))) diff --git a/femtolisp/torus.lsp b/femtolisp/torus.lsp index e4a6848..dd62299 100644 --- a/femtolisp/torus.lsp +++ b/femtolisp/torus.lsp @@ -1,4 +1,5 @@ -(defun maplist (f l) +; -*- scheme -*- +(define (maplist f l) (if (null l) () (cons (f l) (maplist f (cdr l))))) @@ -6,37 +7,37 @@ ; make m copies of a CDR-circular list of length n, and connect corresponding ; conses in CAR-circular loops ; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use -(defun torus (m n) +(define (torus m n) (let* ((l (map-int identity n)) (g l) (prev g)) (dotimes (i (- m 1)) - (setq prev g) - (setq g (maplist identity g)) - (rplacd (last prev) prev)) - (rplacd (last g) g) + (set! prev g) + (set! g (maplist identity g)) + (set-cdr! (last prev) prev)) + (set-cdr! (last g) g) (let ((a l) (b g)) (dotimes (i n) - (rplaca a b) - (setq a (cdr a)) - (setq b (cdr b)))) + (set-car! a b) + (set! a (cdr a)) + (set! b (cdr b)))) l)) -(defun cyl (m n) +(define (cyl m n) (let* ((l (map-int identity n)) (g l)) (dotimes (i (- m 1)) - (setq g (maplist identity g))) + (set! g (maplist identity g))) (let ((a l) (b g)) (dotimes (i n) - (rplaca a b) - (setq a (cdr a)) - (setq b (cdr b)))) + (set-car! a b) + (set! a (cdr a)) + (set! b (cdr b)))) l)) -(time (progn (print (torus 100 100)) nil)) +(time (begin (print (torus 100 100)) ())) ;(time (dotimes (i 1) (load "100x100.lsp"))) ; with ltable ; printing time: 0.415sec diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp index a9e2c23..9518c2d 100644 --- a/femtolisp/unittest.lsp +++ b/femtolisp/unittest.lsp @@ -1,3 +1,4 @@ +; -*- scheme -*- (define (every-int n) (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n) (int64 n) (uint64 n))) @@ -7,7 +8,7 @@ (define (each f l) (if (atom l) () - (progn (f (car l)) + (begin (f (car l)) (each f (cdr l))))) (define (each^2 f l m) @@ -15,7 +16,7 @@ (define (test-lt a b) (each^2 (lambda (neg pos) - (progn + (begin (eval `(assert (= -1 (compare ,neg ,pos)))) (eval `(assert (= 1 (compare ,pos ,neg)))))) a @@ -23,7 +24,7 @@ (define (test-eq a b) (each^2 (lambda (a b) - (progn + (begin (eval `(assert (= 0 (compare ,a ,b)))))) a b)) diff --git a/femtolisp/wt.lsp b/femtolisp/wt.lsp index 0f0875a..31183d3 100644 --- a/femtolisp/wt.lsp +++ b/femtolisp/wt.lsp @@ -1,8 +1,8 @@ -(setq i 0) -(defmacro while- (test . forms) +(set! i 0) +(define-macro (while- test . forms) `((label -loop- (lambda () (if ,test - (progn ,@forms + (begin ,@forms (-loop-)) - nil))))) -(while (< i 10000000) (setq i (+ i 1))) + nil))))) +(while (< i 10000000) (set! i (+ i 1))) diff --git a/llt/int2str.c b/llt/int2str.c index 7f87960..255754c 100644 --- a/llt/int2str.c +++ b/llt/int2str.c @@ -4,9 +4,12 @@ char *int2str(char *dest, size_t n, long num, uint32_t base) { int i = n-1; - int b = (int)base; - int neg = (num<0 ? 1 : 0); + int b = (int)base, neg = 0; char ch; + if (num < 0) { + num = -num; + neg = 1; + } dest[i--] = '\0'; while (i >= 0) { ch = (char)(num % b);