ref: a55b46e9a6af38081aa9376b1f57f1e0d48dc057
parent: 38cf75733ec31e720c67f5be454ba524d37112f9
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Jan 28 20:04:23 EST 2009
switching to scheme #t, #f, and () values porting code to sort out which NILs are false and which are empty lists switching to scheme-style special forms. however you feel about scheme names vs. CL names, using both is silly. mostly switching to scheme predicate names, with compatibility aliases for now. adding set-constant! to make this efficient. adding null?, eqv?, assq, assv, assoc, memq, memv, member adding 2-argument form of if allowing else as final cond condition looking for init file in same directory as executable, so flisp can be started from anywhere renaming T to FL_T, since exporting a 1-character symbol is not very nice adding opaque type boilerplate example file adding correctness checking for the pattern-lambda benchmark bugfix in int2str
--- 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,13 +137,13 @@
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)
@@ -149,6 +150,6 @@
(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)))))
--- 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
--- /dev/null
+++ b/femtolisp/ast/rpasses-out.lsp
@@ -1,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))))))))
--- 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*))
-; (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)
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -81,21 +81,32 @@
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 @@
// 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 @@
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 @@
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 @@
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 @@
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 @@
}
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 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 },--- 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,14 +72,14 @@
(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))
@@ -85,10 +86,10 @@
(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))
--- 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,20 +9,20 @@
,(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*
@@ -28,10 +29,10 @@
(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,7 +199,7 @@
(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))))
@@ -205,11 +206,11 @@
(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 @@
(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)))))
|#
--- a/femtolisp/cvalues.c
+++ b/femtolisp/cvalues.c
@@ -617,7 +617,12 @@
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]));
}
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -256,8 +256,8 @@
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);
}
/*
--- 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 @@
// 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 @@
return bind;
v = cdr_(v);
}
- return NIL;
+ return FL_F;
}
/*
@@ -646,7 +647,7 @@
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 @@
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,7 +810,7 @@
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);
@@ -816,17 +817,21 @@
}
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 @@
}
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 @@
}
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 @@
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 @@
}
tail_eval(car_(*pv));
}
- v = NIL;
+ v = FL_F;
break;
case F_TRYCATCH:
v = do_trycatch(car(Stack[saveSP]), penv);
@@ -900,13 +905,13 @@
// 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 @@
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,37 +1020,48 @@
}
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;
for (i=saveSP+1; i < (int)SP; i++) {@@ -1157,21 +1173,39 @@
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:
argcount("eval", nargs, 1);v = Stack[SP-1];
@@ -1207,9 +1241,9 @@
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 @@
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 @@
}
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 @@
}
// not reached
}
+ apply_type_error:
type_error("apply", "function", f);notpair:
lerror(TypeError, "expected cons");
@@ -1369,7 +1408,7 @@
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 @@
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 @@
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 @@
((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 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 @@
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");--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -103,18 +103,21 @@
// 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);
--- /dev/null
+++ b/femtolisp/opaque_type_template.c
@@ -1,0 +1,63 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdarg.h>
+#include <string.h>
+#include <assert.h>
+#include <sys/types.h>
+#include "llt.h"
+#include "flisp.h"
+
+// global replace TYPE with your type name to make your very own type!
+
+static value_t TYPEsym;
+static fltype_t *TYPEtype;
+
+void print_TYPE(value_t v, ios_t *f, int princ)
+{+}
+
+void print_traverse_TYPE(value_t self)
+{+}
+
+void free_TYPE(value_t self)
+{+}
+
+void relocate_TYPE(value_t oldv, value_t newv)
+{+}
+
+cvtable_t TYPE_vtable = { print_TYPE, relocate_TYPE, free_TYPE,+ print_traverse_TYPE };
+
+int isTYPE(value_t v)
+{+ return iscvalue(v) && cv_class((cvalue_t*)ptr(v)) == TYPEtype;
+}
+
+value_t fl_TYPEp(value_t *args, uint32_t nargs)
+{+ argcount("TYPE?", nargs, 1);+ return isTYPE(args[0]) ? FL_T : FL_F;
+}
+
+static TYPE_t *toTYPE(value_t v, char *fname)
+{+ if (!isTYPE(v))
+ type_error(fname, "TYPE", v);
+ return (TYPE_t*)cv_data((cvalue_t*)ptr(v));
+}
+
+static builtinspec_t TYPEfunc_info[] = {+ { "TYPE?", fl_TYPEp },+ { NULL, NULL }+};
+
+void TYPE_init()
+{+ TYPEsym = symbol("TYPE");+ TYPEtype = define_opaque_type(TYPEsym, sizeof(TYPE_t),
+ &TYPE_vtable, NULL);
+ assign_global_builtins(TYPEfunc_info);
+}
--- a/femtolisp/perf.lsp
+++ b/femtolisp/perf.lsp
@@ -9,7 +9,7 @@
(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: ")
@@ -16,10 +16,13 @@
(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 "..")
--- a/femtolisp/pisum.lsp
+++ b/femtolisp/pisum.lsp
@@ -1,4 +1,4 @@
-(defun pisum ()
+(define (pisum)
(dotimes (j 500)
((label sumloop
(lambda (i sum)
--- a/femtolisp/print.c
+++ b/femtolisp/print.c
@@ -169,7 +169,7 @@
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 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 @@
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 @@
(n > 0 && always) ||
(n == 2 && after3) ||
+ (n == 1 && after2) ||
(n_unindented >= 3 && !nextsmall) ||
@@ -328,8 +336,6 @@
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 @@
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 @@
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;
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -270,12 +270,6 @@
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 @@
value_t v, sym, oldtokval, *head;
value_t *pv;
u_int32_t t;
+ char c;
t = peek(f);
take();
@@ -511,8 +506,18 @@
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();
--- a/femtolisp/stream.c
+++ b/femtolisp/stream.c
@@ -31,8 +31,8 @@
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 builtinspec_t streamfunc_info[] = {- { "streamp", fl_streamp },+ { "stream?", fl_streamp }, { NULL, NULL }};
--- a/femtolisp/string.c
+++ b/femtolisp/string.c
@@ -37,8 +37,8 @@
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 @@
{int term=0;
if (nargs == 2) {- term = (POP() != NIL);
+ term = (POP() != FL_F);
nargs--;
}
argcount("string.decode", nargs, 1);@@ -254,7 +254,7 @@
{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 @@
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 @@
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 @@
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 },--- 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,26 +73,44 @@
(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)))))
@@ -85,17 +117,17 @@
(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,10 +233,10 @@
(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)))
@@ -216,8 +243,8 @@
(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,12 +259,8 @@
(if (null lst) zero
(foldl f (f (car lst) zero) (cdr lst))))
-(define (reverse lst) (foldl cons nil lst))
+(define (reverse lst) (foldl cons () lst))
-(defun reduce (f zero lst)
- (if (null lst) zero
- (reduce f (f zero (car lst)) (cdr lst))))
-
(define (copy-list l)
(if (atom l) l
(cons (car l)
@@ -248,57 +271,57 @@
(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)
@@ -305,13 +328,13 @@
(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)
@@ -318,10 +341,10 @@
; (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)
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -70,8 +70,8 @@
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 @@
{ 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 @@
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 },--- 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)
--- 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,7 +51,7 @@
(list piv)
(sort (cdr halves))))))
-(defmacro dotimes (var . body)
+(define-macro (dotimes var . body)
(let ((v (car var))
(cnt (cadr var)))
`(let ((,v 0))
@@ -56,22 +58,22 @@
(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)
- (for ,lo ,hi
+ `(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)))))))
--- 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
--- 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))
--- 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)))
--- 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);