ref: eceeddf6d218e12cefb36fb9594c29be37852dd2
parent: c61dc10002d41b6be70bd328038eef014f293074
author: JeffBezanson <[email protected]>
date: Sun Jul 26 23:34:33 EDT 2009
adding support for optional arguments error checking formal argument lists making filter preserve the order of elements in the input list
--- a/femtolisp/ast/rpasses-out.lsp
+++ b/femtolisp/ast/rpasses-out.lsp
@@ -5,25 +5,31 @@
(*named* class (r-call
c "POSIXt" "POSIXct")))))))
(<- Sys.timezone (lambda ()
- (let () (r-block (r-call as.vector (r-call
- Sys.getenv "TZ"))))))
+ (let ()
+ (r-block (r-call as.vector (r-call
+ Sys.getenv
+ "TZ"))))))
(<- as.POSIXlt (lambda (x tz)
- (let ((x ()) (tzone ()) (fromchar ()) (tz ()))
+ (let ((x ())
+ (tzone ())
+ (fromchar ())
+ (tz ()))
(r-block (when (missing tz)
(<- tz ""))
(<- fromchar (lambda (x)
- (let ((res ()) (f
- ())
- (j ()) (xx ()))
+ (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-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
@@ -37,25 +43,19 @@
(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))
+ (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")
+ (if (r-call inherits x "POSIXlt")
(return x))
- (if (r-call inherits x
- "Date")
+ (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"))
+ (<- 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
@@ -87,26 +87,25 @@
(<- 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
+ (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 (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")))))
+ 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")
+ (let ((x ())
+ (z ()))
+ (r-block (if (r-call inherits x "dates")
(r-block (<- z (r-call
attr x "origin"))
(<- x (r-call
@@ -119,13 +118,13 @@
(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")))))
+ 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 ()))
+ (let ((tzone ())
+ (tz ()))
(r-block (when (missing tz)
(<- tz ""))
(<- tzone (r-call attr x
@@ -145,8 +144,7 @@
(let ((tz ()))
(r-block (when (missing tz)
(<- tz ""))
- (if (r-call inherits x
- "POSIXct")
+ (if (r-call inherits x "POSIXct")
(return x))
(if (|\|\|| (r-call
is.character
@@ -174,26 +172,27 @@
(r-call
deparse (substitute x))))))))
(<- as.numeric.POSIXlt (lambda (x)
- (let () (r-block (r-call as.POSIXct 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)
+ (let ((np ())
+ (secs ())
+ (times ())
+ (usetz ())
+ (format ()))
+ (r-block (when (missing format)
(<- format ""))
+ (when (missing usetz)
+ (<- usetz *r-false*))
(if (r-call ! (r-call
inherits x "POSIXlt"))
(r-call stop "wrong class"))
- (if (r-call == format
- "")
+ (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"))))
+ 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
@@ -215,11 +214,9 @@
(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 "")))))))
+ "%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)
@@ -230,21 +227,22 @@
(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*))
+ (let ((tzone ())
+ (usetz ())
+ (tz ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format ""))
(when (missing tz)
(<- tz ""))
- (when (missing format)
- (<- format ""))
+ (when (missing usetz)
+ (<- usetz *r-false*))
(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")))))
+ 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)
@@ -251,20 +249,20 @@
(*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)))))
+ (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)))))
+ (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 ()))
+ (let ((x ())
+ (digits ()))
(r-block (when (missing digits)
(<- digits 15))
(<- x (r-call r-index (r-call
@@ -295,35 +293,32 @@
digits)
r-dotdotdot)))))
(<- "+.POSIXt" (lambda (e1 e2)
- (let ((e2 ()) (e1 ()) (coerceTimeUnit ()))
+ (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)))))))
+ (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"))
+ (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")
+ (if (r-call inherits e1 "POSIXlt")
(<- e1 (r-call as.POSIXct e1)))
- (if (r-call inherits e2
- "POSIXlt")
+ (if (r-call inherits e2 "POSIXlt")
(<- e2 (r-call as.POSIXct e2)))
- (if (r-call inherits e1
- "difftime")
+ (if (r-call inherits e1 "difftime")
(<- e1 (r-call coerceTimeUnit
e1)))
- (if (r-call inherits e2
- "difftime")
+ (if (r-call inherits e2 "difftime")
(<- e2 (r-call coerceTimeUnit
e2)))
(r-call structure (r-call + (r-call
@@ -334,27 +329,27 @@
(*named* tzone (r-call
check_tzones e1 e2)))))))
(<- "-.POSIXt" (lambda (e1 e2)
- (let ((e2 ()) (coerceTimeUnit ()))
+ (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)))))))
+ (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")
+ (if (r-call inherits e2 "POSIXt")
(return (r-call difftime e1
e2)))
- (if (r-call inherits e2
- "difftime")
+ (if (r-call inherits e2 "difftime")
(<- e2 (r-call unclass (r-call
coerceTimeUnit e2))))
(if (r-call ! (r-call is.null (r-call
@@ -366,7 +361,9 @@
(*named* class (r-call c
"POSIXt" "POSIXct")))))))
(<- Ops.POSIXt (lambda (e1 e2)
- (let ((e2 ()) (e1 ()) (boolean ()))
+ (let ((e2 ())
+ (e1 ())
+ (boolean ()))
(r-block (if (r-call == (r-call nargs) 1)
(r-call stop "unary" .Generic
" not defined for \"POSIXt\" objects"))
@@ -406,11 +403,8 @@
(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)))))))
+ (r-block (<- y (r-call attr x "tzone"))
+ (if (r-call is.null y) "" y)))))))
(<- tzs (r-call r-index tzs
(r-call != tzs
"")))
@@ -422,7 +416,10 @@
(r-call r-index tzs 1)
())))))
(<- Summary.POSIXct (lambda (... na.rm)
- (let ((val ()) (tz ()) (args ()) (ok ()))
+ (let ((val ())
+ (tz ())
+ (args ())
+ (ok ()))
(r-block (<- ok (switch .Generic (*named*
max *r-missing*)
(*named* min
@@ -450,7 +447,10 @@
tz)
val))))
(<- Summary.POSIXlt (lambda (... na.rm)
- (let ((val ()) (tz ()) (args ()) (ok ()))
+ (let ((val ())
+ (tz ())
+ (args ())
+ (ok ()))
(r-block (<- ok (switch .Generic (*named*
max *r-missing*)
(*named* min
@@ -472,11 +472,13 @@
.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"))
+ structure val (*named* class (r-call c "POSIXt" "POSIXct"))
(*named* tzone tz)))))))
(<- "[.POSIXct" (lambda (x ... drop)
- (let ((val ()) (x ()) (cl ()) (drop ()))
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
(r-block (when (missing drop)
(<- drop *r-true*))
(<- cl (r-call oldClass x))
@@ -494,7 +496,10 @@
%r:4)
val))))
(<- "[[.POSIXct" (lambda (x ... drop)
- (let ((val ()) (x ()) (cl ()) (drop ()))
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
(r-block (when (missing drop)
(<- drop *r-true*))
(<- cl (r-call oldClass x))
@@ -513,7 +518,10 @@
%r:5)
val))))
(<- "[<-.POSIXct" (lambda (x ... value)
- (let ((x ()) (tz ()) (cl ()) (value ()))
+ (let ((x ())
+ (tz ())
+ (cl ())
+ (value ()))
(r-block (if (r-call ! (r-call
as.logical (r-call
length value)))
@@ -521,10 +529,11 @@
(<- value (r-call as.POSIXct
value))
(<- cl (r-call oldClass x))
- (<- tz (r-call attr x
- "tzone"))
+ (<- tz (r-call attr x "tzone"))
(r-block (ref= %r:6 (r-block
- (<- value (r-call class<- value ())) ()))
+ (<- value (r-call class<- value
+ ()))
+ ()))
(<- x (r-call class<-
x %r:6))
%r:6)
@@ -538,13 +547,14 @@
tz)
x))))
(<- as.character.POSIXt (lambda (x ...)
- (let () (r-block (r-call format x
- r-dotdotdot)))))
+ (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))))))
+ (let ()
+ (r-block (r-call is.na (r-call
+ as.POSIXct x))))))
(<- c.POSIXct (lambda (... recursive)
(let ((recursive ()))
(r-block (when (missing recursive)
@@ -567,7 +577,8 @@
target current)
(r-call NextMethod "all.equal")))))
(<- ISOdatetime (lambda (year month day hour min sec tz)
- (let ((x ()) (tz ()))
+ (let ((x ())
+ (tz ()))
(r-block (when (missing tz)
(<- tz ""))
(<- x (r-call paste year month
@@ -580,43 +591,50 @@
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))
+ (let ((tz ())
+ (sec ())
+ (min ())
+ (hour ()))
+ (r-block (when (missing hour)
+ (<- hour 12))
(when (missing min)
(<- min 0))
- (when (missing hour)
- (<- hour 12))
+ (when (missing sec)
+ (<- sec 0))
+ (when (missing tz)
+ (<- tz "GMT"))
(r-call ISOdatetime year month day
hour min sec tz)))))
(<- as.matrix.POSIXlt (lambda (x ...)
- (let () (r-block (r-call as.matrix (r-call
+ (let ()
+ (r-block (r-call as.matrix (r-call
as.data.frame (r-call unclass x))
- r-dotdotdot)))))
+ 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
+ (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
+ (*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))))))
+ (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)
+ (let ((zz ())
+ (z ())
+ (time2 ())
+ (time1 ())
+ (units ())
+ (tz ()))
+ (r-block (when (missing tz)
(<- tz ""))
+ (when (missing units)
+ (<- units (r-call c "auto" "secs"
+ "mins" "hours"
+ "days" "weeks")))
(<- time1 (r-call as.POSIXct time1
(*named* tz tz)))
(<- time2 (r-call as.POSIXct time2
@@ -625,8 +643,7 @@
time1)
(r-call unclass time2)))
(<- units (r-call match.arg units))
- (if (r-call == units
- "auto")
+ (if (r-call == units "auto")
(r-block (if (r-call all (r-call
is.na z))
(<- units "secs")
@@ -633,12 +650,11 @@
(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"))))))))
+ (<- 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")))
@@ -673,13 +689,13 @@
(*named*
class "difftime"))))))))
(<- as.difftime (lambda (tim format units)
- (let ((format ()) (units ()))
- (r-block (when (missing units)
- (<- units "auto"))
- (when (missing format)
+ (let ((units ())
+ (format ()))
+ (r-block (when (missing format)
(<- format "%X"))
- (if (r-call inherits tim
- "difftime")
+ (when (missing units)
+ (<- units "auto"))
+ (if (r-call inherits tim "difftime")
(return tim))
(if (r-call is.character tim)
(r-block (r-call difftime (r-call
@@ -695,9 +711,7 @@
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")))
+ %in% units (r-call c "secs" "mins" "hours" "days" "weeks")))
(r-call stop "invalid units specified"))
(r-call structure
tim (*named*
@@ -709,17 +723,17 @@
(<- "units<-" (lambda (x value)
(let () (r-block (r-call UseMethod "units<-")))))
(<- units.difftime (lambda (x)
- (let () (r-block (r-call attr x
- "units")))))
+ (let ()
+ (r-block (r-call attr x "units")))))
(<- "units<-.difftime" (lambda (x value)
- (let ((newx ()) (sc ()) (from ()))
+ (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")))
+ %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)
@@ -732,11 +746,11 @@
value)
(*named* class "difftime"))))))
(<- as.double.difftime (lambda (x units ...)
- (let ((x ()) (units ()))
+ (let ((x ())
+ (units ()))
(r-block (when (missing units)
(<- units "auto"))
- (if (r-call != units
- "auto")
+ (if (r-call != units "auto")
(r-block (<- x (r-call
units<- x units))
units))
@@ -745,11 +759,13 @@
(<- 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))))))
+ (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 ()))
+ (let ((y ())
+ (digits ()))
(r-block (when (missing digits)
(<- digits (r-call
getOption
@@ -760,14 +776,12 @@
length x)
1))
(r-block (r-call cat "Time differences in "
- (r-call attr x
- "units")
- "\n" (*named* sep ""))
+ (r-call attr x "units") "\n" (*named* sep ""))
(<- y (r-call
unclass x))
(r-block (<- y
- (r-call attr<- y
- "units" ()))
+ (r-call attr<- y "units"
+ ()))
())
(r-call print y))
(r-call cat "Time difference of "
@@ -774,24 +788,26 @@
(r-call format (r-call
unclass x)
(*named* digits digits))
- " "
- (r-call attr x
- "units")
- "\n"
- (*named* sep "")))
+ " " (r-call attr
+ x "units")
+ "\n" (*named* sep
+ "")))
(r-call invisible x)))))
(<- round.difftime (lambda (x digits ...)
- (let ((units ()) (digits ()))
+ (let ((units ())
+ (digits ()))
(r-block (when (missing digits)
(<- digits 0))
- (<- units (r-call attr x
- "units"))
+ (<- 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 ()))
+ (let ((val ())
+ (x ())
+ (cl ())
+ (drop ()))
(r-block (when (missing drop)
(<- drop *r-true*))
(<- cl (r-call oldClass x))
@@ -810,11 +826,13 @@
%r:7)
val))))
(<- Ops.difftime (lambda (e1 e2)
- (let ((u1 ()) (e2 ()) (boolean ()) (e1 ()) (coerceTimeUnit
- ()))
+ (let ((u1 ())
+ (e2 ())
+ (boolean ())
+ (e1 ())
+ (coerceTimeUnit ()))
(r-block (<- coerceTimeUnit (lambda (x)
- (let () (r-block (switch (r-call attr x
- "units")
+ (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))
@@ -852,16 +870,12 @@
(*named* >=
*r-true*)
*r-false*))
- (if boolean
- (r-block (if (&& (r-call
+ (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))
+ (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 ==
@@ -868,27 +882,20 @@
.Generic "-"))
(r-block (if (&& (r-call
inherits e1 "difftime")
- (r-call ! (r-call inherits e2
- "difftime")))
+ (r-call ! (r-call inherits e2 "difftime")))
(return (r-call structure (r-call NextMethod .Generic)
- (*named* units (r-call attr e1
- "units"))
+ (*named* units (r-call attr e1 "units"))
(*named* class "difftime"))))
(if (&& (r-call
- ! (r-call inherits e1
- "difftime"))
- (r-call inherits e2
- "difftime"))
+ ! (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* 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-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))
@@ -899,14 +906,13 @@
(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"))
+ (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")
+ (if (r-call inherits e2 "difftime")
(r-block (<- tmp e1)
(<- e1 e2)
(<- e2 tmp)))
@@ -916,25 +922,27 @@
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
+ (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"))))))
+ (*named* class "difftime"))))))
(<- Math.difftime (lambda (x ...)
- (let () (r-block (r-call stop .Generic
- "not defined for \"difftime\" objects")))))
+ (let ()
+ (r-block (r-call stop .Generic
+ "not defined for \"difftime\" objects")))))
(<- mean.difftime (lambda (x ... na.rm)
- (let ((args ()) (coerceTimeUnit ()) (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")
+ (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
@@ -957,15 +965,14 @@
(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* units (r-call attr x "units"))
(*named* class "difftime"))))))))
(<- Summary.difftime (lambda (... na.rm)
- (let ((args ()) (ok ()) (coerceTimeUnit
- ()))
+ (let ((args ())
+ (ok ())
+ (coerceTimeUnit ()))
(r-block (<- coerceTimeUnit (lambda (x)
- (let () (r-block (r-call as.vector (switch (r-call attr x
- "units")
+ (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
@@ -996,15 +1003,24 @@
(*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)
+ (let ((mon ())
+ (yr ())
+ (r1 ())
+ (by2 ())
+ (by ())
+ (valid ())
+ (res ())
+ (to ())
+ (from ())
+ (status ())
+ (tz ())
+ (cfrom ())
+ (along.with ())
+ (length.out ()))
+ (r-block (when (missing length.out)
(<- length.out ()))
+ (when (missing along.with)
+ (<- along.with ()))
(if (missing from)
(r-call stop "'from' must be specified"))
(if (r-call ! (r-call inherits
@@ -1015,8 +1031,7 @@
cfrom)
1)
(r-call stop "'from' must be of length 1"))
- (<- tz (r-call attr cfrom
- "tzone"))
+ (<- tz (r-call attr cfrom "tzone"))
(if (r-call ! (missing to))
(r-block (if (r-call ! (r-call
inherits to "POSIXt"))
@@ -1060,8 +1075,7 @@
(return (r-call
structure
res (*named*
- class (r-call c "POSIXt"
- "POSIXct"))
+ class (r-call c "POSIXt" "POSIXct"))
(*named*
tzone tz)))))
(if (r-call != (r-call length by)
@@ -1068,18 +1082,16 @@
1)
(r-call stop "'by' must be of length 1"))
(<- valid 0)
- (if (r-call inherits by
- "difftime")
+ (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 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*))
+ r-aref (r-call strsplit by " "
+ (*named* fixed *r-true*))
1))
(if (|\|\|| (r-call
> (r-call length by2) 2)
@@ -1089,10 +1101,7 @@
(<- valid (r-call
pmatch (r-call r-index by2
(r-call length by2))
- (r-call c "secs"
- "mins" "hours" "days"
- "weeks" "months" "years"
- "DSTdays")))
+ (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
(if (r-call
is.na valid)
(r-call stop
@@ -1103,12 +1112,11 @@
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))))))
+ (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))
+ (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))
@@ -1131,8 +1139,7 @@
(return (r-call
structure
res (*named*
- class (r-call c "POSIXt"
- "POSIXct"))
+ class (r-call c "POSIXt" "POSIXct"))
(*named*
tzone tz))))
(r-block (<- r1 (r-call
@@ -1152,13 +1159,10 @@
(index-in-strlist year (r-call attr
r1 #0#)))
(r-call r-aref to
- (index-in-strlist year (r-call attr to
- #0#)))
+ (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))
+ (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
@@ -1169,12 +1173,11 @@
(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))))
+ (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
@@ -1193,9 +1196,7 @@
to #0#))))
by))))
(r-block (<- r1 (r-call r-aref<- r1
- (index-in-strlist mon (r-call attr r1
- #0#))
- mon))
+ (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
@@ -1205,54 +1206,55 @@
(<- 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 (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#)))
+ (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#))
+ (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#))
+ (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)))))))))
+ (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*))
+ (let ((res ())
+ (maxx ())
+ (incr ())
+ (start ())
+ (valid ())
+ (by2 ())
+ (breaks ())
+ (x ())
+ (right ())
+ (start.on.monday ())
+ (labels ()))
+ (r-block (when (missing labels)
+ (<- labels ()))
(when (missing start.on.monday)
(<- start.on.monday
*r-true*))
- (when (missing labels)
- (<- labels ()))
+ (when (missing right)
+ (<- right *r-false*))
(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")
+ (if (r-call inherits breaks "POSIXt")
(r-block (<- breaks (r-call
as.POSIXct breaks)))
(if (&& (r-call is.numeric
@@ -1268,8 +1270,8 @@
length breaks)
1))
(r-block (<- by2 (r-call
- r-aref (r-call strsplit breaks
- " " (*named* fixed *r-true*))
+ 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))
@@ -1277,10 +1279,7 @@
(<- valid (r-call
pmatch (r-call r-index by2
(r-call length by2))
- (r-call c "secs"
- "mins" "hours" "days"
- "weeks" "months" "years"
- "DSTdays")))
+ (r-call c "secs" "mins" "hours" "days" "weeks" "months" "years" "DSTdays")))
(if (r-call
is.na valid)
(r-call stop "invalid specification of 'breaks'"))
@@ -1325,20 +1324,20 @@
#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
+ (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))
+ %r:14))
+ %r:14))
(<- incr (r-call * 7 86400))))
(if (r-call
== valid 6)
@@ -1400,7 +1399,8 @@
(<- julian (lambda (x ...)
(let () (r-block (r-call UseMethod "julian")))))
(<- julian.POSIXt (lambda (x origin ...)
- (let ((res ()) (origin ()))
+ (let ((res ())
+ (origin ()))
(r-block (when (missing origin)
(<- origin (r-call
as.POSIXct
@@ -1427,8 +1427,7 @@
(r-call format x
(r-call ifelse
abbreviate
- "%a"
- "%A"))))))
+ "%a" "%A"))))))
(<- months (lambda (x abbreviate)
(let () (r-block (r-call UseMethod "months")))))
(<- months.POSIXt (lambda (x abbreviate)
@@ -1452,7 +1451,8 @@
(r-call + x 1)
(*named* sep ""))))))
(<- trunc.POSIXt (lambda (x units)
- (let ((x ()) (units ()))
+ (let ((x ())
+ (units ()))
(r-block (when (missing units)
(<- units (r-call c "secs"
"mins" "hours" "days")))
@@ -1460,8 +1460,7 @@
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#))))
+ 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
@@ -1468,42 +1467,29 @@
(index-in-strlist sec (r-call
attr x #0#)))))
(<- x (r-call r-aref<- x
- (index-in-strlist sec (r-call attr x
- #0#))
+ (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))
+ (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))
+ (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))
+ (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))
+ (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))
+ (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))
+ (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
@@ -1512,7 +1498,8 @@
%r:17)))))
x))))
(<- round.POSIXt (lambda (x units)
- (let ((x ()) (units ()))
+ (let ((x ())
+ (units ()))
(r-block (when (missing units)
(<- units (r-call c "secs"
"mins" "hours" "days")))
@@ -1530,13 +1517,13 @@
(r-call trunc.POSIXt x
(*named* units units))))))
(<- "[.POSIXlt" (lambda (x ... drop)
- (let ((val ()) (drop ()))
+ (let ((val ())
+ (drop ()))
(r-block (when (missing drop)
(<- drop *r-true*))
- (<- val (r-call lapply x
- "[" r-dotdotdot
- (*named* drop
- drop)))
+ (<- val (r-call lapply x "["
+ r-dotdotdot (*named*
+ drop drop)))
(r-block (ref= %r:18 (r-call
attributes x))
(<- val (r-call
@@ -1545,7 +1532,9 @@
%r:18)
val))))
(<- "[<-.POSIXlt" (lambda (x i value)
- (let ((x ()) (cl ()) (value ()))
+ (let ((x ())
+ (cl ())
+ (value ()))
(r-block (if (r-call ! (r-call
as.logical (r-call
length value)))
@@ -1554,7 +1543,9 @@
value))
(<- cl (r-call oldClass x))
(r-block (ref= %r:19 (r-block
- (<- value (r-call class<- value ())) ()))
+ (<- value (r-call class<- value
+ ()))
+ ()))
(<- x (r-call class<-
x %r:19))
%r:19)
@@ -1570,15 +1561,16 @@
cl)
x))))
(<- as.data.frame.POSIXlt (lambda (x row.names optional ...)
- (let ((value ()) (row.names ()) (optional
- ()))
+ (let ((value ())
+ (optional ())
+ (row.names ()))
(r-block (when (missing
+ row.names)
+ (<- row.names ()))
+ (when (missing
optional)
(<- optional
*r-false*))
- (when (missing
- row.names)
- (<- row.names ()))
(<- value (r-call
as.data.frame.POSIXct
(r-call
@@ -1611,22 +1603,24 @@
%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)
+ (let ((i1 ())
+ (xlen ())
+ (r ())
+ (ismat ())
+ (differences ())
+ (lag ()))
+ (r-block (when (missing lag)
(<- lag 1))
+ (when (missing differences)
+ (<- differences 1))
(<- ismat (r-call is.matrix x))
- (<- r (if (r-call inherits x
- "POSIXlt")
+ (<- r (if (r-call inherits x "POSIXlt")
(r-call as.POSIXct x)
x))
- (<- xlen (if ismat
- (r-call r-index (r-call
+ (<- xlen (if ismat (r-call
+ r-index (r-call
dim x)
- 1)
+ 1)
(r-call length r)))
(if (|\|\|| (r-call > (r-call
length lag)
@@ -1650,20 +1644,15 @@
units "secs"))))
(<- i1 (r-call : (r-call - 1)
(r-call - lag)))
- (if ismat
- (for i (r-call : 1
- differences)
- (<- r (r-call - (r-call
+ (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*)))))
+ (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
@@ -1676,7 +1665,8 @@
1))))))))
r))))
(<- duplicated.POSIXlt (lambda (x incomparables ...)
- (let ((x ()) (incomparables ()))
+ (let ((x ())
+ (incomparables ()))
(r-block (when (missing
incomparables)
(<- incomparables
@@ -1694,11 +1684,12 @@
(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)
+ (let ((na.last ())
+ (decreasing ()))
+ (r-block (when (missing decreasing)
(<- decreasing *r-false*))
+ (when (missing na.last)
+ (<- na.last NA))
(r-call r-index x
(r-call order (r-call
as.POSIXct x)
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -26,6 +26,7 @@
:add2 :sub2 :neg :largc :lvargc
:loada0 :loada1 :loadc00 :loadc01 :call.l :tcall.l
:brne :brne.l :cadr :brnn :brnn.l :brn :brn.l
+ :optargs
dummy_t dummy_f dummy_nil]))
(for 0 (1- (length keys))
@@ -171,7 +172,7 @@
((number? nxt)
(case vi
((:loadv.l :loadg.l :setg.l :loada.l :seta.l
- :largc :lvargc :call.l :tcall.l)
+ :largc :lvargc :call.l :tcall.l :optargs)
(io.write bcode (int32 nxt))
(set! i (+ i 1)))
@@ -346,6 +347,7 @@
(if (and (pair? head)
(eq? (car head) 'lambda)
(list? (cadr head))
+ (every symbol? (cadr head))
(not (length> (cadr head) 255)))
(compile-let g env tail? x)
(compile-call g env tail? x))))
@@ -505,6 +507,28 @@
(else ())))))
(lambda (expr) (delete-duplicates (get-defined-vars- expr)))))
+(define (lambda-vars l)
+ (define (check-formals l o)
+ (or
+ (null? l) (symbol? l)
+ (and
+ (pair? l)
+ (or (symbol? (car l))
+ (and (pair? (car l))
+ (or (every pair? (cdr l))
+ (error (string "compile error: invalid argument list "
+ o ". optional arguments must come last."))))
+ (error (string "compile error: invalid formal argument " (car l)
+ " in list " o)))
+ (check-formals (cdr l) o))
+ (if (eq? l o)
+ (error (string "compile error: invalid argument list " o))
+ (error (string "compile error: invalid formal argument " l
+ " in list " o)))))
+ (check-formals l l)
+ (map (lambda (s) (if (pair? s) (car s) s))
+ (to-proper l)))
+
(define compile-f-
(let ((*defines-processed-token* (gensym)))
; to eval a top-level expression we need to avoid internal define
@@ -529,24 +553,35 @@
(let ((g (make-code-emitter))
(args (cadr f))
+ (vars (lambda-vars (cadr f)))
+ (opta (filter pair? (cadr f)))
(name (if (eq? (lastcdr f) *defines-processed-token*)
'lambda
(lastcdr f))))
- (cond ((not (null? let?)) (emit g :let))
- ((length> args 255) (emit g (if (null? (lastcdr args))
- :largc :lvargc)
- (length args)))
- ((null? (lastcdr args)) (emit g :argc (length args)))
- (else (emit g :vargc (if (atom? args) 0 (length args)))))
- (compile-in g (cons (to-proper args) env) #t
- (if (eq? (lastcdr f) *defines-processed-token*)
- (caddr f)
- (lambda-body f)))
- (emit g :ret)
- (values (function (encode-byte-code (bcode:code g))
- (const-to-idx-vec g) name)
- (aref g 3))))))
+ (let ((nargs (if (atom? args) 0 (length args))))
+ ; emit argument checking prologue
+ (if (not (null? opta))
+ (begin (bcode:indexfor g (list->vector (map cadr opta)))
+ (emit g :optargs (- nargs (length opta)))))
+
+ (cond ((not (null? let?)) (emit g :let))
+ ((> nargs 255) (emit g (if (null? (lastcdr args))
+ :largc :lvargc)
+ nargs))
+ ((null? (lastcdr args)) (emit g :argc nargs))
+ (else (emit g :vargc nargs)))
+
+ ; compile body and return
+ (compile-in g (cons vars env) #t
+ (if (eq? (lastcdr f) *defines-processed-token*)
+ (caddr f)
+ (lambda-body f)))
+ (emit g :ret)
+ (values (function (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g) name)
+ (aref g 3)))))))
+
(define (compile f) (compile-f () f))
(define (ref-int32-LE a i)
@@ -604,7 +639,7 @@
(princ (number->string (aref code i)))
(set! i (+ i 1)))
- ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l)
+ ((:loada.l :seta.l :largc :lvargc :call.l :tcall.l :optargs)
(princ (number->string (ref-int32-LE code i)))
(set! i (+ i 4)))
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -1,1 +1,1 @@
-(zero? #function("7000r1~`W;" [] zero?) vector.map #function("8000r2c0e1\x7f31u42;" [#function("8000vc0e1~31u42;" [#function(":000v`\x80azc0qw2~;" [#function(":000r1\x80~i20i21~[31\\;" [])]) vector.alloc]) length] vector.map) vector->list #function("9000r1c0e1~31_u43;" [#function(":000va~c0qw2\x7f;" [#function("8000r1i10\x80~z[\x81Ko01;" [])]) length] vector->list) values #function("9000s0~F16602~NA650~M;\x80~K;" [] #5=[(*values*) ()]) untrace #function("8000r1c0e1~31u42;" [#function("9000ve0~316@0e1\x80e2~31b2[42;^;" [traced? set-top-level-value! function:vals]) top-level-value] untrace) traced? #function("8000r1e0~31e0\x8031>;" [function:code] [#function(":000s0e0c1~K312c2~x2;" [println x #.apply]) ()]) trace #function("8000r1c0e1~31u322c2;" [#function("8000vc0e130u42;" [#function("?000ve0\x80317a0e1i10e2c3~c4c5c6c7i10L2~L3L2c8c7\x80L2~L3L3L33142;^;" [traced? set-top-level-value! eval lambda begin println cons quote apply]) gensym]) top-level-value ok] trace) to-proper #function("9000r1~\x8740~;~?660~L1;~Me0~N31K;" [to-proper] to-proper) table.values #function("9000r1e0c1_~43;" [table.foldl #function("7000r3\x7fg2K;" [])] table.values) table.pairs #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~\x7fKg2K;" [])] table.pairs) table.keys #function("9000r1e0c1_~43;" [table.foldl #function("7000r3~g2K;" [])] table.keys) table.invert #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80\x7f~43;" [put!])]) table] table.invert) table.foreach #function("9000r2e0c1q_\x7f43;" [table.foldl #function("8000r3\x80~\x7f322];" [])] table.foreach) table.clone #function("8000r1c0e130u42;" [#function("9000ve0c1q_\x80332~;" [table.foldl #function("9000r3e0\x80~\x7f43;" [put!])]) table] table.clone) symbol-syntax #function("9000r1e0e1~^43;" [get *syntax-environment*] symbol-syntax) string.trim #function("9000r3c0^^u43;" [#function("8000vc0qm02c1qm12c2e3\x8031u42;" [#function(";000r4g2g3X16?02e0\x7fe1~g232326A0\x80~\x7fe2~g232g344;g2;" [string.find string.char string.inc] trim-start) #function("<000r3e0g2`3216D02e1\x7fe2~e3~g23232326?0\x81~\x7fe3~g23243;g2;" [> string.find string.char string.dec] trim-end) #function("<000ve0i10\x80i10i11`~34\x81i10i12~3343;" [string.sub]) length])] string.trim) string.tail #function(";000r2e0~e1~`\x7f3342;" [string.sub string.inc] string.tail) string.rpad #function("<000r3e0~e1g2\x7fe2~31z3242;" [string string.rep string.count] string.rpad) string.rep #function(";000r2\x7fb4X6`0e0\x7f`32650c1;\x7faW680e2~41;\x7fb2W690e2~~42;e2~~~43;e3\x7f316@0e2~e4~\x7faz3242;e4e2~~32\x7fb2U242;" [<= "" string odd? string.rep] string.rep) string.map #function("9000r2c0e130e2\x7f31u43;" [#function("8000vc0`u322e1~41;" [#function(";000v^~\x81X6S02e0\x80i10e1i11~3231322e2i11~32m05\x0b/;" [io.putc string.char string.inc]) io.tostring!]) buffer length] string.map) string.lpad #function(";000r3e0e1g2\x7fe2~31z32~42;" [string string.rep string.count] string.lpad) string.join #function("8000r2~\x8750c0;c1e230u42;" ["" #function("8000ve0~\x80M322e1c2q\x80N322e3~41;" [io.write for-each #function("8000r1e0\x80i11322e0\x80~42;" [io.write]) io.tostring!]) buffer] string.join) simple-sort #function("8000r1~A17602~NA640~;c0~Mu42;" [#function("9000vc0e1c2q\x80N32u42;" [#function(":000ve0e1~M31\x80L1e1~N3143;" [nconc simple-sort]) separate #function("7000r1~\x80X;" [])])] simple-sort) set-syntax! #function("9000r2e0e1~\x7f43;" [put! *syntax-environment*] set-syntax!) separate #function(":000r2\x80~\x7f__44;" [] #0=[#function("6000r4\x7f\x8780g2g3K;~\x7fM316@0\x80~\x7fN\x7fMg2Kg344;\x80~\x7fNg2\x7fMg3K44;" [] #0#) ()]) self-evaluating? #function("8000r1~?16602~C@17K02e0~3116A02~C16:02~e1~31<;" [constant? top-level-value] self-evaluating?) reverse! #function("8000r1c0_u42;" [#function("9000v^\x80F6C02\x80N\x80~\x80m02P2o005\x1c/2~;" [])] reverse!) reverse #function("9000r1e0c1_~43;" [foldl #.cons] reverse) revappend #function("8000r2e0e1~31\x7f42;" [nconc reverse] revappend) repl #function("9000r0c0^^u43;" [#function("6000vc0m02c1qm12\x7f302e240;" [#function("8000r0e0c1312e2e3312c4c5c6tu\ No newline at end of file
+(*banner* "; _\n; |_ _ _ |_ _ | . _ _\n; | (-||||_(_)|__|_)|_)\n;-------------------|----------------------------------------------------------\n\n" *syntax-environment* #table(assert #function("<000r1c0~]c1c2c3~L2L2L2L4;" [if raise quote assert-failed]) letrec #function("?000s1e0e0c1L1e2c3~32L1e2c4~32e5\x7f3134L1e2c6~3242;" [nconc lambda map #.car #function("9000r1e0c1L1e2~3142;" [nconc set! copy-list]) copy-list #function("6000r1^;" [])]) backquote #function("7000r1e0~41;" [bq-process]) label #function(":000r2c0~L1c1~\x7fL3L3^L2;" [lambda set!]) do #function("A000s2c0e130\x7fMe2c3~32e2e4~32e2c5~32u46;" [#function("B000vc0~c1g2c2\x7fe3c4L1e5\x81N3132e3c4L1e5i0231e3~L1g432L133L4L3L2L1e3~L1g332L3;" [letrec lambda if nconc begin copy-list]) gensym map #.car cadr #function("7000r1e0~31F680e1~41;~M;" [cddr caddr])]) when #function("<000s1c0~c1\x7fK^L4;" [if begin]) unwind-protect #function("9000r2c0e130e130u43;" [#function("@000vc0\x7fc1_\x81L3L2L1c2c3\x80c1~L1c4\x7fL1c5~L2L3L3L3\x7fL1L3L3;" [let lambda prog1 trycatch begin raise]) gensym]) dotimes #function("<000s1c0~M~\x86u43;" [#function("=000vc0`c1\x7faL3e2c3L1~L1L1e4\x813133L4;" [for - nconc lambda copy-list])]) define-macro #function("?000s1c0c1~ML2e2c3L1~NL1e4\x7f3133L3;" [set-syntax! quote nconc lambda copy-list]) receive #function("@000s2c0c1_\x7fL3e2c1L1~L1e3g23133L3;" [call-with-values lambda nconc copy-list]) unless #function("=000s1c0~^c1\x7fKL4;" [if begin]) let #function(";000s1c0^u42;" [#function("<000v\x80C6D0\x80m02\x81Mo002\x81No01530^2c0e1c2L1e3c4\x8032L1e5\x813133e3c6\x8032u43;" [#function("8000v\x806;0c0\x80~L3530~\x7fK;" [label]) nconc lambda map #function("6000r1~F650~M;~;" []) copy-list #function("6000r1~F650~\x86;^;" [])])]) cond #function(":000s0c0^u42;" [#function("7000vc0qm02~\x8041;" [#function("8000r1~?640^;c0~Mu42;" [#function(";000v~Mc0<17702~M]<6@0~N\x8750~M;c1~NK;~N\x87@0c2~Mi10\x80N31L3;c3~Mc1~NKi10\x80N31L4;" [else begin or if])] cond-clauses->if)])]) throw #function(":000r2c0c1c2c3L2~\x7fL4L2;" [raise list quote thrown-value]) time #function("8000r1c0e130u42;" [#function(">000vc0~c1L1L2L1c2\x80c3c4c5c1L1~L3c6L4L3L3;" [let time.now prog1 princ "Elapsed time: " - " seconds\n"]) gensym]) let* #function("A000s1~?6E0e0c1L1_L1e2\x7f3133L1;e0c1L1e3~31L1L1e2~NF6H0e0c4L1~NL1e2\x7f3133L1530\x7f3133e5~31L2;" [nconc lambda copy-list caar let* cadar]) case #function(";000s1c0^u42;" [#function("8000vc0m02c1e230u42;" [#function(";000r2\x7fc0\x8450c0;\x7f\x8740^;\x7fC6=0c1~e2\x7f31L3;\x7f?6=0c3~e2\x7f31L3;\x7fN\x87>0c3~e2\x7fM31L3;e4c5\x7f326=0c6~c7\x7fL2L3;c8~c7\x7fL2L3;" [else eq? quote-value eqv? every #.symbol? memq quote memv] vals->cond) #function("<000vc0~i10L2L1e1c2L1e3c4qi113232L3;" [let nconc cond map #function("8000r1i10\x80~M32~NK;" [])]) gensym])]) catch #function("8000r2c0e130u42;" [#function("@000vc0\x81c1~L1c2c3c4~L2c5c6~L2c7c8L2L3c5c9~L2\x80L3L4c:~L2c;~L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) *whitespace* "\t\n\v\f\r \u0085 \u2028\u2029 " /= #function("7000r2~\x7fW@;" [] /=) 1+ #function("7000r1~ay;" [] 1+) 1- #function("7000r1~az;" [] 1-) 1arg-lambda? #function("8000r1~F16T02~Mc0<16J02~NF16B02~\x86F16:02e1~\x86a42;" [lambda length=] 1arg-lambda?) <= #function("7000r2~\x7fX17602~\x7fW;" [] <=) > #function("7000r2\x7f~X;" [] >) >= #function("7000r2\x7f~X17602~\x7fW;" [] >=) Instructions #table(:sub2 74 :nop 0 :set-cdr! 32 :/ 37 :setc 63 :tapply 72 :lvargc 77 :cons 27 :loada1 79 :tcall.l 83 dummy_nil 94 :equal? 14 :cdr 30 :call 3 :eqv? 13 := 39 :setg.l 60 :list 28 :atom? 15 :aref 43 :load0 48 :let 70 dummy_t 92 :argc 66 :brne.l 85 :< 40 :null? 17 :loadg 53 :load1 49 :car 29 :brt.l 10 :vargc 67 :loada 55 :set-car! 31 :setg 59 :aset! 44 :loadc01 81 :bound? 21 :optargs 91 :pair? 22 :symbol? 19 :brn 89 :fixnum? 25 :loadi8 50 :not 16 :* 36 :neg 75 :pop 2 :largc 76 :loadnil 47 :brf 6 :vector 42 :- 35 :loadv 51 :loada.l 56 :seta.l 62 :closure 65 :loadc00 80 :number? 2\ No newline at end of file
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -931,6 +931,30 @@
Stack[SP-1] = 0;
curr_frame = SP;
NEXT_OP;
+ OP(OP_OPTARGS)
+ n = GET_INT32(ip); ip+=4;
+ v = fn_vals(Stack[bp-1]);
+ v = vector_elt(v, 0);
+ if (nargs >= n) { // if we have all required args+ s = vector_size(v);
+ n += s;
+ if (nargs < n) { // but not all optional args+ i = n - nargs;
+ SP += i;
+ Stack[SP-1] = Stack[SP-i-1];
+ Stack[SP-2] = Stack[SP-i-2];
+ Stack[SP-3] = Stack[SP-i-3];
+ Stack[SP-4] = Stack[SP-i-4];
+ Stack[SP-5] = Stack[SP-i-5];
+ curr_frame = SP;
+ s = s - i;
+ for(n=0; n < i; n++) {+ Stack[bp+nargs+n] = vector_elt(v, s+n);
+ }
+ nargs += i;
+ }
+ }
+ NEXT_OP;
OP(OP_NOP) NEXT_OP;
OP(OP_DUP) SP++; Stack[SP-1] = Stack[SP-2]; NEXT_OP;
OP(OP_POP) POPN(1); NEXT_OP;
@@ -1662,7 +1686,7 @@
#endif
}
-static uint32_t compute_maxstack(uint8_t *code, size_t len)
+static uint32_t compute_maxstack(uint8_t *code, size_t len, value_t vals)
{uint8_t *ip = code+4, *end = code+len;
uint8_t op;
@@ -1688,6 +1712,12 @@
sp += (n+2);
break;
case OP_LET: break;
+ case OP_OPTARGS:
+ ip += 4;
+ assert(isvector(vals));
+ if (vector_size(vals) > 0)
+ sp += vector_size(vector_elt(vals, 0));
+ break;
case OP_TCALL: case OP_CALL:
n = *ip++; // nargs
@@ -1824,7 +1854,7 @@
for(i=0; i < sz; i++)
data[i] -= 48;
}
- uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr));
+ uint32_t ms = compute_maxstack((uint8_t*)data, cv_len(arr), args[1]);
PUT_INT32(data, ms);
function_t *fn = (function_t*)alloc_words(4);
value_t fv = tagptr(fn, TAG_FUNCTION);
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -27,6 +27,7 @@
OP_TAPPLY, OP_ADD2, OP_SUB2, OP_NEG, OP_LARGC, OP_LVARGC,
OP_LOADA0, OP_LOADA1, OP_LOADC00, OP_LOADC01, OP_CALLL, OP_TCALLL,
OP_BRNE, OP_BRNEL, OP_CADR, OP_BRNN, OP_BRNNL, OP_BRN, OP_BRNL,
+ OP_OPTARGS,
OP_BOOL_CONST_T, OP_BOOL_CONST_F, OP_THE_EMPTY_LIST,
@@ -69,7 +70,7 @@
&&L_OP_LVARGC, \
&&L_OP_LOADA0, &&L_OP_LOADA1, &&L_OP_LOADC00, &&L_OP_LOADC01, \
&&L_OP_CALLL, &&L_OP_TCALLL, &&L_OP_BRNE, &&L_OP_BRNEL, &&L_OP_CADR,\
- &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL \
+ &&L_OP_BRNN, &&L_OP_BRNNL, &&L_OP_BRN, &&L_OP_BRNL, &&L_OP_OPTARGS \
}
#define VM_APPLY_LABELS \
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -224,15 +224,16 @@
(set-car! lst (f (car lst)))
(set! lst (cdr lst)))))
-(define filter
- (letrec ((filter-
- (lambda (pred lst accum)
- (cond ((null? lst) accum)
- ((pred (car lst))
- (filter- pred (cdr lst) (cons (car lst) accum)))
- (#t
- (filter- pred (cdr lst) accum))))))
- (lambda (pred lst) (filter- pred lst ()))))
+(define (filter pred lst)
+ (define (filter- f lst acc)
+ (cdr
+ (prog1 acc
+ (while (pair? lst)
+ (begin (if (pred (car lst))
+ (set! acc
+ (cdr (set-cdr! acc (cons (car lst) ())))))
+ (set! lst (cdr lst)))))))
+ (filter- pred lst (list ())))
(define separate
(letrec ((separate-
--- a/femtolisp/todo
+++ b/femtolisp/todo
@@ -159,7 +159,7 @@
. write a function to evaluate directly from list to list, use it for
Nth arg and for user function rest args
. modify vararg builtins accordingly
-- filter should be stable. right now it reverses.
+* filter should be stable. right now it reverses.
femtoLisp3...with symbolic C interface
@@ -975,7 +975,8 @@
- remaining c types
- remaining cvalues functions
- finish ios
-- optional and keyword arguments
+* optional arguments
+- keyword arguments
- some kind of record, struct, or object system
- special efficient reader for #array
@@ -1042,6 +1043,8 @@
* try removing MAX_ARGS trickery
- apply optimization, avoid redundant list copying calling vararg fns
- let eversion
+- variable analysis - avoid holding references to values in frames
+ captured by closures but not used inside them
* lambda lifting
* let optimization
* fix equal? on functions
--- a/femtolisp/unittest.lsp
+++ b/femtolisp/unittest.lsp
@@ -116,6 +116,14 @@
(assert (equal? (apply f (iota 995)) '(994)))
(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
+; optional arguments
+(assert (equal? ((lambda ((b 0)) b)) 0))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+
; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
(assert (equal? (fib 20) 6765))