ref: f1fe3edd47f3250db4de381fe3cbfd242028a70e
parent: ed2b11a8ac69cd8296aa0910f2f08c5f2cab2752
author: Jeff Bezanson <bezanson@post.harvard.edu>
date: Fri Feb 17 12:39:41 EST 2012
some more renaming
--- a/femtolisp/ast/asttools.lsp
+++ /dev/null
@@ -1,171 +1,0 @@
-; -*- scheme -*-
-; utilities for AST processing
-
-(define (symconcat s1 s2)
- (symbol (string s1 s2)))
-
-(define (list-adjoin item lst)
- (if (member item lst)
- lst
- (cons item lst)))
-
-(define (index-of item lst start)
- (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
- (begin (f (car l))
- (each f (cdr l)))))
-
-(define (maptree-pre f tr)
- (let ((new-t (f tr)))
- (if (pair? new-t)
- (map (lambda (e) (maptree-pre f e)) new-t)
- new-t)))
-
-(define (maptree-post f tr)
- (if (not (pair? tr))
- (f tr)
- (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
- (f new-t))))
-
-(define (foldtree-pre f t zero)
- (if (not (pair? t))
- (f t zero)
- (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero))))
-
-(define (foldtree-post f t zero)
- (if (not (pair? t))
- (f t zero)
- (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
-
-; general tree transformer
-; folds in preorder (foldtree-pre), maps in postorder (maptree-post)
-; therefore state changes occur immediately, just by looking at the current node,
-; while transformation follows evaluation order. this seems to be the most natural
-; approach.
-; (mapper tree state) - should return transformed tree given current state
-; (folder tree state) - should return new state
-(define (map&fold t zero mapper folder)
- (let ((head (and (pair? t) (car t))))
- (cond ((eq? head 'quote)
- t)
- ((or (eq? head 'the) (eq? head 'meta))
- (list head
- (cadr t)
- (map&fold (caddr t) zero mapper folder)))
- (else
- (let ((new-s (folder t zero)))
- (mapper
- (if (pair? t)
- ; head symbol is a tag; never transform it
- (cons (car t)
- (map (lambda (e) (map&fold e new-s mapper folder))
- (cdr t)))
- t)
- new-s))))))
-
-; convert to proper list, i.e. remove "dots", and append
-(define (append.2 l tail)
- (cond ((null? l) tail)
- ((atom? l) (cons l tail))
- (#t (cons (car l) (append.2 (cdr l) tail)))))
-
-; transform code by calling (f expr env) on each subexpr, where
-; env is a list of lexical variables in effect at that point.
-(define (lexical-walk f t)
- (map&fold t () f
- (lambda (tree state)
- (if (and (eq? (car t) 'lambda)
- (pair? (cdr t)))
- (append.2 (cadr t) state)
- state))))
-
-; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
-(define (flatten-left-op op e)
- (maptree-post (lambda (node)
- (if (and (pair? node)
- (eq (car node) op)
- (pair? (cdr node))
- (pair? (cadr node))
- (eq (caadr node) op))
- (cons op
- (append (cdadr node) (cddr node)))
- node))
- e))
-
-; convert all local variable references to (lexref rib slot name)
-; where rib is the nesting level and slot is the stack slot#
-; name is just there for reference
-; this assumes lambda is the only remaining naming form
-(define (lookup-var v env lev)
- (if (null? env) v
- (let ((i (index-of v (car env) 0)))
- (if i (list 'lexref lev i v)
- (lookup-var v (cdr env) (+ lev 1))))))
-(define (lvc- e env)
- (cond ((symbol? e) (lookup-var e env 0))
- ((pair? e)
- (if (eq (car e) 'quote)
- e
- (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
- (newenv (if newvs (cons newvs env) env)))
- (if newvs
- (cons 'lambda
- (cons (cadr e)
- (map (lambda (se) (lvc- se newenv))
- (cddr e))))
- (map (lambda (se) (lvc- se env)) e)))))
- (#t e)))
-(define (lexical-var-conversion e)
- (lvc- e ()))
-
-; convert let to lambda
-(define (let-expand e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'let))
- `((lambda ,(map car (cadr n)) ,@(cddr n))
- ,@(map cadr (cadr n)))
- n))
- e))
-
-; alpha renaming
-; transl is an assoc list ((old-sym-name . new-sym-name) ...)
-(define (alpha-rename e transl)
- (map&fold e
- ()
- ; mapper: replace symbol if unbound
- (lambda (t env)
- (if (symbol? t)
- (let ((found (assq t transl)))
- (if (and found
- (not (memq t env)))
- (cdr found)
- t))
- t))
- ; folder: add locals to environment if entering a new scope
- (lambda (t env)
- (if (and (pair? t) (or (eq? (car t) 'let)
- (eq? (car t) 'lambda)))
- (append (cadr t) env)
- env))))
-
-; flatten op with any associativity
-(define-macro (flatten-all-op op e)
- `(pattern-expand
- (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
- (cons ',op (append l (cdr inner) r)))
- ,e))
-
-(define-macro (pattern-lambda pat body)
- (let* ((args (patargs pat))
- (expander `(lambda ,args ,body)))
- `(lambda (expr)
- (let ((m (match ',pat expr)))
- (if m
- ; matches; perform expansion
- (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
- ',args))
- #f)))))
--- a/femtolisp/ast/datetimeR.lsp
+++ /dev/null
@@ -1,79 +1,0 @@
-'(r-expressions
- (<- Sys.time (function () (r-call structure (r-call .Internal (r-call Sys.time)) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
- (<- Sys.timezone (function () (r-call as.vector (r-call Sys.getenv "TZ")) ()))
- (<- as.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- fromchar (function ((*named* x *r-missing*)) (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-call attr res "tzone") 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 (function ((*named* x *r-missing*) (*named* tz "")) (r-call UseMethod "as.POSIXct") ()))
- (<- as.POSIXct.Date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call * (r-call unclass x) 86400) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
- (<- as.POSIXct.date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- 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 (function ((*named* x *r-missing*) (*named* tz "")) (r-block (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 (function ((*named* x *r-missing*)) (r-call as.POSIXct x) ()))
- (<- format.POSIXlt (function ((*named* x *r-missing*) (*named* format "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (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 ($ x sec)) (<- 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))) 1e-06)) (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 (function ((*named* x *r-missing*) (*named* format *r-missing*) (*named* tz "")) (r-call .Internal (r-call strptime (r-call as.character x) format tz)) ()))
- (<- format.POSIXct (function ((*named* x *r-missing*) (*named* format "") (*named* tz "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*) r-dotdotdot) r-dotdotdot) (r-call invisible x)) ()))
- (<- print.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*)) r-dotdotdot) (r-call invisible x)) ()))
- (<- summary.POSIXct (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-block (<- x (r-call r-index (r-call summary.default (r-call unclass object) (*named* digits digits) r-dotdotdot) (r-call : 1 6))) (<- (r-call class x) (r-call oldClass object)) (<- (r-call attr x "tzone") (r-call attr object "tzone")) x) ()))
- (<- summary.POSIXlt (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-call summary (r-call as.POSIXct object) (*named* digits digits) r-dotdotdot) ()))
- (<- "+.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic " not defined for POSIXt objects")) ()))
- (<- check_tzones (function ((*named* ... *r-missing*)) (r-block (<- tzs (r-call unique (r-call sapply (r-call list r-dotdotdot) (function ((*named* x *r-missing*)) (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 (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (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-call class val) (r-call oldClass (r-call r-aref args 1))) (<- (r-call attr val "tzone") tz) val) ()))
- (<- Summary.POSIXlt (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (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" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
- (<- "[[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
- (<- "[<-.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* value *r-missing*)) (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-call class x) (<- (r-call class value) ())) (<- x (r-call NextMethod .Generic)) (<- (r-call class x) cl) (<- (r-call attr x "tzone") tz) x) ()))
- (<- as.character.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call format x r-dotdotdot) ()))
- (<- as.data.frame.POSIXct as.data.frame.vector)
- (<- is.na.POSIXlt (function ((*named* x *r-missing*)) (r-call is.na (r-call as.POSIXct x)) ()))
- (<- c.POSIXct (function ((*named* ... *r-missing*) (*named* 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 (function ((*named* ... *r-missing*) (*named* 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 (function ((*named* target *r-missing*) (*named* current *r-missing*) (*named* ... *r-missing*) (*named* scale 1)) (r-block (r-call check_tzones target current) (r-call NextMethod "all.equal")) ()))
- (<- ISOdatetime (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour *r-missing*) (*named* min *r-missing*) (*named* sec *r-missing*) (*named* tz "")) (r-block (<- 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 (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour 12) (*named* min 0) (*named* sec 0) (*named* tz "GMT")) (r-call ISOdatetime year month day hour min sec tz) ()))
- (<- as.matrix.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call as.matrix (r-call as.data.frame (r-call unclass x)) r-dotdotdot)) ()))
- (<- mean.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call as.POSIXlt (r-call mean (r-call as.POSIXct x) r-dotdotdot)) ()))
- (<- difftime (function ((*named* time1 *r-missing*) (*named* time2 *r-missing*) (*named* tz "") (*named* units (r-call c "auto" "secs" "mins" "hours" "days" "weeks"))) (r-block (<- 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 (function ((*named* tim *r-missing*) (*named* format "%X") (*named* units "auto")) (r-block (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 (function ((*named* x *r-missing*)) (r-call UseMethod "units") ()))
- (<- "units<-" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-call UseMethod "units<-") ()))
- (<- units.difftime (function ((*named* x *r-missing*)) (r-call attr x "units") ()))
- (<- "units<-.difftime" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* units "auto") (*named* ... *r-missing*)) (r-block (if (r-call != units "auto") (<- (r-call units x) units)) (r-call as.double (r-call as.vector x))) ()))
- (<- as.data.frame.difftime as.data.frame.vector)
- (<- format.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call paste (r-call format (r-call unclass x) r-dotdotdot) (r-call units x)) ()))
- (<- print.difftime (function ((*named* x *r-missing*) (*named* digits (r-call getOption "digits")) (*named* ... *r-missing*)) (r-block (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-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 (function ((*named* x *r-missing*) (*named* digits 0) (*named* ... *r-missing*)) (r-block (<- units (r-call attr x "units")) (r-call structure (r-call NextMethod) (*named* units units) (*named* class "difftime"))) ()))
- (<- "[.difftime" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "units") (r-call attr x "units")) val) ()))
- (<- Ops.difftime (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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-call r-index e1 *r-missing*) (r-call - (r-call unclass e1))))) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic "not defined for \"difftime\" objects")) ()))
- (<- mean.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* na.rm *r-false*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* from *r-missing*) (*named* to *r-missing*) (*named* by *r-missing*) (*named* length.out ()) (*named* along.with ()) (*named* ... *r-missing*)) (r-block (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 ($ r1 year) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- yr (r-call seq.int ($ r1 year) ($ to year) by)))) (<- ($ r1 year) yr) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 6) (r-block (if (missing to) (r-block (<- mon (r-call seq.int ($ r1 mon) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- mon (r-call seq.int ($ r1 mon) (r-call + (r-call * 12 (r-call - ($ to year) ($ r1 year))) ($ to mon)) by)))) (<- ($ r1 mon) mon) (<- ($ r1 isdst) (r-call - 1)) (<- 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.POSI
\ No newline at end of file
- (<- cut.POSIXt (function ((*named* x *r-missing*) (*named* breaks *r-missing*) (*named* labels ()) (*named* start.on.monday *r-true*) (*named* right *r-false*) (*named* ... *r-missing*)) (r-block (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 (<- ($ start sec) 0) (<- incr 59.99))) (if (r-call > valid 2) (r-block (<- ($ start min) 0) (<- incr (r-call - 3600 1)))) (if (r-call > valid 3) (r-block (<- ($ start hour) 0) (<- incr (r-call - 86400 1)))) (if (r-call == valid 5) (r-block (<- ($ start mday) (r-call - ($ start mday) ($ start wday))) (if start.on.monday (<- ($ start mday) (r-call + ($ start mday) (r-call ifelse (r-call > ($ start wday) 0) 1 (r-call - 6))))) (<- incr (r-call * 7 86400)))) (if (r-call == valid 6) (r-block (<- ($ start mday) 1) (<- incr (r-call * 31 86400)))) (if (r-call == valid 7) (r-block (<- ($ start mon) 0) (<- ($ start mday) 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-call levels res) (r-call as.character (r-call r-index breaks (r-call - (r-call length breaks)))))) res) ()))
- (<- julian (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call UseMethod "julian") ()))
- (<- julian.POSIXt (function ((*named* x *r-missing*) (*named* origin (r-call as.POSIXct "1970-01-01" (*named* tz "GMT"))) (*named* ... *r-missing*)) (r-block (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 (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "weekdays") ()))
- (<- weekdays.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%a" "%A"))) ()))
- (<- months (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "months") ()))
- (<- months.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%b" "%B"))) ()))
- (<- quarters (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "quarters") ()))
- (<- quarters.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- x (r-call %/% ($ (r-call as.POSIXlt x) mon) 3)) (r-call paste "Q" (r-call + x 1) (*named* sep ""))) ()))
- (<- trunc.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (<- units (r-call match.arg units)) (<- x (r-call as.POSIXlt x)) (if (r-call > (r-call length ($ x sec)) 0) (switch units (*named* secs (r-block (<- ($ x sec) (r-call trunc ($ x sec))))) (*named* mins (r-block (<- ($ x sec) 0))) (*named* hours (r-block (<- ($ x sec) 0) (<- ($ x min) 0))) (*named* days (r-block (<- ($ x sec) 0) (<- ($ x min) 0) (<- ($ x hour) 0) (<- ($ x isdst) (r-call - 1)))))) x) ()))
- (<- round.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (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" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- val (r-call lapply x "[" r-dotdotdot (*named* drop drop))) (<- (r-call attributes val) (r-call attributes x)) val) ()))
- (<- "[<-.POSIXlt" (function ((*named* x *r-missing*) (*named* i *r-missing*) (*named* value *r-missing*)) (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-call class x) (<- (r-call class value) ())) (for n (r-call names x) (<- (r-call r-index (r-call r-aref x n) i) (r-call r-aref value n))) (<- (r-call class x) cl) x) ()))
- (<- as.data.frame.POSIXlt (function ((*named* x *r-missing*) (*named* row.names ()) (*named* optional *r-false*) (*named* ... *r-missing*)) (r-block (<- value (r-call as.data.frame.POSIXct (r-call as.POSIXct x) row.names optional r-dotdotdot)) (if (r-call ! optional) (<- (r-call names value) (r-call r-aref (r-call deparse (substitute x)) 1))) value) ()))
- (<- rep.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call lapply x rep r-dotdotdot)) (<- (r-call attributes y) (r-call attributes x)) y) ()))
- (<- diff.POSIXt (function ((*named* x *r-missing*) (*named* lag 1) (*named* differences 1) (*named* ... *r-missing*)) (r-block (<- 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 (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-block (<- x (r-call as.POSIXct x)) (r-call NextMethod "duplicated" x)) ()))
- (<- unique.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-call r-index x (r-call ! (r-call duplicated x incomparables r-dotdotdot))) ()))
- (<- sort.POSIXlt (function ((*named* x *r-missing*) (*named* decreasing *r-false*) (*named* na.last NA) (*named* ... *r-missing*)) (r-call r-index x (r-call order (r-call as.POSIXct x) (*named* na.last na.last) (*named* decreasing decreasing))) ())))
--- a/femtolisp/ast/match.lsp
+++ /dev/null
@@ -1,181 +1,0 @@
-; -*- scheme -*-
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-(define (unique lst)
- (if (null? lst)
- ()
- (cons (car lst)
- (filter (lambda (x) (not (eq x (car lst))))
- (unique (cdr lst))))))
-
-; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
-
-; expression tree pattern matching
-; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
-; mapping variables to captured subexpressions, or #f if no match.
-; when a match succeeds, __ is always bound to the whole matched expression.
-;
-; p is an expression in the following pattern language:
-;
-; _ match anything, not captured
-; <func> any scheme function; matches if (func expr) returns #t
-; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
-; must match the same thing.
-; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
-; subpatterns matched recursively.
-; (-/ <ex>) match <ex> literally
-; (-^ <p>) complement of pattern <p>
-; (-- <var> <p>) match <p> and capture as <var> if match succeeds
-;
-; regular match constructs:
-; ... match any number of anything
-; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
-; (-* <p>) match any number of <p>
-; (-? <p>) match 0 or 1 of <p>
-; (-+ <p>) match at least 1 of <p>
-; all of these can be wrapped in (-- var ) for capturing purposes
-; This is NP-complete. Be careful.
-;
-(define (match- p expr state)
- (cond ((symbol? p)
- (cond ((eq p '_) state)
- (#t
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((procedure? p)
- (and (p expr) state))
-
- ((pair? p)
- (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq (car p) '--)
- (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 #f 1))
- (#t
- (and (pair? expr)
- (equal? (car p) (car expr))
- (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
- (#t
- (and (equal? p expr) state))))
-
-; match an alternation
-(define (match-alt alt prest expr state var L)
- (if (null? alt) #f ; no alternatives left
- (let ((subma (match- (car alt) (car expr) state)))
- (or (and subma
- (match-seq prest (cdr expr)
- (if var
- (cons (cons var (car expr))
- subma)
- subma)
- (- L 1)))
- (match-alt (cdr alt) prest expr state var L)))))
-
-; match generalized kleene star (try consuming min to max)
-(define (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) #f)
- ; case 1: only allowed to match 0 subexpressions
- ((= max 0) (match-seq prest expr
- (if var (cons (cons var (reverse sofar)) state)
- state)
- L))
- ; case 2: must match at least 1
- ((> min 0)
- (and (match- p (car expr) state)
- (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
- (cons (car expr) sofar))))
- ; otherwise, must match either 0 or between 1 and max subexpressions
- (#t
- (or (match-star- p prest expr state var 0 0 L sofar)
- (match-star- p prest expr state var 1 max L sofar)))))
-(define (match-star p prest expr state var min max L)
- (match-star- p prest expr state var min max L ()))
-
-; match sequences of expressions
-(define (match-seq p expr state L)
- (cond ((not state) #f)
- ((null? p) (if (null? expr) state #f))
- (#t
- (let ((subp (car p))
- (var #f))
- (if (and (pair? subp)
- (eq (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- #f)
- (let ((head (if (pair? subp) (car subp) ())))
- (cond ((eq subp '...)
- (match-star '_ (cdr p) expr state var 0 L L))
- ((eq head '-*)
- (match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq head '-+)
- (match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq head '-?)
- (match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq head '-$)
- (match-alt (cdr subp) (cdr p) expr state var L))
- (#t
- (and (pair? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(define (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(define (patargs- p)
- (cond ((and (symbol? p)
- (not (member p metasymbols)))
- (list p))
-
- ((pair? p)
- (if (eq (car p) '-/)
- ()
- (unique (apply append (map patargs- (cdr p))))))
-
- (#t ())))
-(define (patargs p)
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
- (if (null? plist) expr
- (if (procedure? plist)
- (let ((enew (plist expr)))
- (if (not enew)
- expr
- enew))
- (let ((enew ((car plist) expr)))
- (if (not enew)
- (apply-patterns (cdr plist) expr)
- enew)))))
-
-; top-down fixed-point macroexpansion. this is a typical algorithm,
-; but it may leave some structure that matches a pattern unexpanded.
-; the advantage is that non-terminating cases cannot arise as a result
-; of expression composition. in other words, if the outer loop terminates
-; on all inputs for a given set of patterns, then the whole algorithm
-; terminates. pattern sets that violate this should be easier to detect,
-; for example
-; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
-; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
- (if (not (pair? expr))
- expr
- (let ((enew (apply-patterns plist expr)))
- (if (eq enew expr)
- ; expr didn't change; move to subexpressions
- (cons (car expr)
- (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
- ; expr changed; iterate
- (pattern-expand plist enew)))))
--- a/femtolisp/ast/match.scm
+++ /dev/null
@@ -1,174 +1,0 @@
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-; list of special pattern symbols that cannot be variable names
-(define metasymbols '(_ ...))
-
-; expression tree pattern matching
-; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
-; mapping variables to captured subexpressions, or #f if no match.
-; when a match succeeds, __ is always bound to the whole matched expression.
-;
-; p is an expression in the following pattern language:
-;
-; _ match anything, not captured
-; <func> any scheme function; matches if (func expr) returns #t
-; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
-; must match the same thing.
-; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
-; subpatterns matched recursively.
-; (-/ <ex>) match <ex> literally
-; (-^ <p>) complement of pattern <p>
-; (-- <var> <p>) match <p> and capture as <var> if match succeeds
-;
-; regular match constructs:
-; ... match any number of anything
-; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
-; (-* <p>) match any number of <p>
-; (-? <p>) match 0 or 1 of <p>
-; (-+ <p>) match at least 1 of <p>
-; all of these can be wrapped in (-- var ) for capturing purposes
-; This is NP-complete. Be careful.
-;
-(define (match- p expr state)
- (cond ((symbol? p)
- (cond ((eq? p '_) state)
- (else
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((procedure? p)
- (and (p expr) state))
-
- ((pair? p)
- (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
- ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
- ((eq? (car p) '--)
- (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 #f 1))
- (else
- (and (pair? expr)
- (equal? (car p) (car expr))
- (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
-
- (else
- (and (equal? p expr) state))))
-
-; match an alternation
-(define (match-alt alt prest expr state var L)
- (if (null? alt) #f ; no alternatives left
- (let ((subma (match- (car alt) (car expr) state)))
- (or (and subma
- (match-seq prest (cdr expr)
- (if var
- (cons (cons var (car expr))
- subma)
- subma)
- (- L 1)))
- (match-alt (cdr alt) prest expr state var L)))))
-
-; match generalized kleene star (try consuming min to max)
-(define (match-star p prest expr state var min max L)
- (define (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) #f)
- ; case 1: only allowed to match 0 subexpressions
- ((= max 0) (match-seq prest expr
- (if var (cons (cons var (reverse sofar)) state)
- state)
- L))
- ; case 2: must match at least 1
- ((> min 0)
- (and (match- p (car expr) state)
- (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
- (cons (car expr) sofar))))
- ; otherwise, must match either 0 or between 1 and max subexpressions
- (else
- (or (match-star- p prest expr state var 0 0 L sofar)
- (match-star- p prest expr state var 1 max L sofar)))))
-
- (match-star- p prest expr state var min max L ()))
-
-; match sequences of expressions
-(define (match-seq p expr state L)
- (cond ((not state) #f)
- ((null? p) (if (null? expr) state #f))
- (else
- (let ((subp (car p))
- (var #f))
- (if (and (pair? subp)
- (eq? (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- #f)
- (let ((head (if (pair? subp) (car subp) ())))
- (cond ((eq? subp '...)
- (match-star '_ (cdr p) expr state var 0 L L))
- ((eq? head '-*)
- (match-star (cadr subp) (cdr p) expr state var 0 L L))
- ((eq? head '-+)
- (match-star (cadr subp) (cdr p) expr state var 1 L L))
- ((eq? head '-?)
- (match-star (cadr subp) (cdr p) expr state var 0 1 L))
- ((eq? head '-$)
- (match-alt (cdr subp) (cdr p) expr state var L))
- (else
- (and (pair? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(define (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(define (patargs p)
- (define (patargs- p)
- (cond ((and (symbol? p)
- (not (member p metasymbols)))
- (list p))
-
- ((pair? p)
- (if (eq? (car p) '-/)
- ()
- (delete-duplicates (apply append (map patargs- (cdr p))))))
-
- (else ())))
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(define (apply-patterns plist expr)
- (if (null? plist) expr
- (if (procedure? plist)
- (let ((enew (plist expr)))
- (if (not enew)
- expr
- enew))
- (let ((enew ((car plist) expr)))
- (if (not enew)
- (apply-patterns (cdr plist) expr)
- enew)))))
-
-; top-down fixed-point macroexpansion. this is a typical algorithm,
-; but it may leave some structure that matches a pattern unexpanded.
-; the advantage is that non-terminating cases cannot arise as a result
-; of expression composition. in other words, if the outer loop terminates
-; on all inputs for a given set of patterns, then the whole algorithm
-; terminates. pattern sets that violate this should be easier to detect,
-; for example
-; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
-; TODO: ignore quoted expressions
-(define (pattern-expand plist expr)
- (if (not (pair? expr))
- expr
- (let ((enew (apply-patterns plist expr)))
- (if (eq? enew expr)
- ; expr didn't change; move to subexpressions
- (cons (car expr)
- (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
- ; expr changed; iterate
- (pattern-expand plist enew)))))
--- a/femtolisp/ast/rpasses-out.lsp
+++ /dev/null
@@ -1,1701 +1,0 @@
-'(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 ())
- (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 "")
- (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 ())
- (usetz ())
- (tz ())
- (format ()))
- (r-block (when (missing format)
- (<- format ""))
- (when (missing tz)
- (<- tz ""))
- (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")))))
- (<- 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 ((tz ())
- (sec ())
- (min ())
- (hour ()))
- (r-block (when (missing hour)
- (<- hour 12))
- (when (missing min)
- (<- min 0))
- (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
- 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 ())
- (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
- (*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 ((units ())
- (format ()))
- (r-block (when (missing format)
- (<- format "%X"))
- (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
- 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 ())
- (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
- 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 ())
- (right ())
- (start.on.monday ())
- (labels ()))
- (r-block (when (missing labels)
- (<- labels ()))
- (when (missing start.on.monday)
- (<- start.on.monday
- *r-true*))
- (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")
- (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 ())
- (optional ())
- (row.names ()))
- (r-block (when (missing
- row.names)
- (<- row.names ()))
- (when (missing
- optional)
- (<- optional
- *r-false*))
- (<- 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 ())
- (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-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 ((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)
- (*named*
- na.last
- na.last)
- (*named*
- decreasing
- decreasing))))))))
--- a/femtolisp/ast/rpasses.lsp
+++ /dev/null
@@ -1,110 +1,0 @@
-; -*- scheme -*-
-(load "match.lsp")
-(load "asttools.lsp")
-
-(define missing-arg-tag '*r-missing*)
-
-; tree inspection utils
-
-(define (assigned-var e)
- (and (pair? e)
- (or (eq (car e) '<-) (eq (car e) 'ref=))
- (symbol? (cadr e))
- (cadr e)))
-
-(define (func-argnames f)
- (let ((argl (cadr f)))
- (if (eq argl '*r-null*) ()
- (map cadr argl))))
-
-; transformations
-
-(let ((ctr 0))
- (set! r-gensym (lambda ()
- (prog1 (symbol (string "%r:" ctr))
- (set! ctr (+ ctr 1))))))
-
-(define (dollarsign-transform e)
- (pattern-expand
- (pattern-lambda ($ lhs name)
- (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
- (n (if (symbol? name)
- name ;(symbol->string name)
- name))
- (expr `(r-call
- r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
- (if (not (pair? lhs))
- expr
- `(r-block (ref= ,g ,lhs) ,expr))))
- e))
-
-; lower r expressions of the form f(lhs,...) <- rhs
-; TODO: if there are any special forms that can be f in this expression,
-; they need to be handled separately. For example a$b can be lowered
-; to an index assignment (by dollarsign-transform), after which
-; this transform applies. I don't think there are any others though.
-(define (fancy-assignment-transform e)
- (pattern-expand
- (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
- (<<- (r-call f lhs ...) rhs))
- (let ((g (if (pair? rhs) (r-gensym) rhs))
- (op (car __)))
- `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
- (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
- ,g)))
- e))
-
-; map an arglist with default values to appropriate init code
-; function(x=blah) { ... } gets-; if (missing(x)) x = blah
-; added to its body
-(define (gen-default-inits arglist)
- (map (lambda (arg)
- (let ((name (cadr arg))
- (default (caddr arg)))
- `(when (missing ,name)
- (<- ,name ,default))))
- (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
-
-; convert r function expressions to lambda
-(define (normalize-r-functions e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'function))
- `(lambda ,(func-argnames n)
- (r-block ,@(gen-default-inits (cadr n))
- ,@(if (and (pair? (caddr n))
- (eq (car (caddr n)) 'r-block))
- (cdr (caddr n))
- (list (caddr n)))))
- n))
- e))
-
-(define (find-assigned-vars n)
- (let ((vars ()))
- (maptree-pre (lambda (s)
- (if (not (pair? s)) s
- (cond ((eq (car s) 'lambda) ())
- ((eq (car s) '<-)
- (set! vars (list-adjoin (cadr s) vars))
- (cddr s))
- (#t s))))
- n)
- vars))
-
-; introduce let based on assignment statements
-(define (letbind-locals e)
- (maptree-post (lambda (n)
- (if (and (pair? n) (eq (car n) 'lambda))
- (let ((vars (find-assigned-vars (cddr n))))
- `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
- vars)
- ,@(cddr n))))
- n))
- e))
-
-(define (compile-ish e)
- (letbind-locals
- (normalize-r-functions
- (fancy-assignment-transform
- (dollarsign-transform
- (flatten-all-op && (flatten-all-op \|\| e)))))))
--- /dev/null
+++ b/femtolisp/tests/ast/asttools.lsp
@@ -1,0 +1,171 @@
+; -*- scheme -*-
+; utilities for AST processing
+
+(define (symconcat s1 s2)
+ (symbol (string s1 s2)))
+
+(define (list-adjoin item lst)
+ (if (member item lst)
+ lst
+ (cons item lst)))
+
+(define (index-of item lst start)
+ (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
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (maptree-pre f tr)
+ (let ((new-t (f tr)))
+ (if (pair? new-t)
+ (map (lambda (e) (maptree-pre f e)) new-t)
+ new-t)))
+
+(define (maptree-post f tr)
+ (if (not (pair? tr))
+ (f tr)
+ (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
+ (f new-t))))
+
+(define (foldtree-pre f t zero)
+ (if (not (pair? t))
+ (f t zero)
+ (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero))))
+
+(define (foldtree-post f t zero)
+ (if (not (pair? t))
+ (f t zero)
+ (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero))))
+
+; general tree transformer
+; folds in preorder (foldtree-pre), maps in postorder (maptree-post)
+; therefore state changes occur immediately, just by looking at the current node,
+; while transformation follows evaluation order. this seems to be the most natural
+; approach.
+; (mapper tree state) - should return transformed tree given current state
+; (folder tree state) - should return new state
+(define (map&fold t zero mapper folder)
+ (let ((head (and (pair? t) (car t))))
+ (cond ((eq? head 'quote)
+ t)
+ ((or (eq? head 'the) (eq? head 'meta))
+ (list head
+ (cadr t)
+ (map&fold (caddr t) zero mapper folder)))
+ (else
+ (let ((new-s (folder t zero)))
+ (mapper
+ (if (pair? t)
+ ; head symbol is a tag; never transform it
+ (cons (car t)
+ (map (lambda (e) (map&fold e new-s mapper folder))
+ (cdr t)))
+ t)
+ new-s))))))
+
+; convert to proper list, i.e. remove "dots", and append
+(define (append.2 l tail)
+ (cond ((null? l) tail)
+ ((atom? l) (cons l tail))
+ (#t (cons (car l) (append.2 (cdr l) tail)))))
+
+; transform code by calling (f expr env) on each subexpr, where
+; env is a list of lexical variables in effect at that point.
+(define (lexical-walk f t)
+ (map&fold t () f
+ (lambda (tree state)
+ (if (and (eq? (car t) 'lambda)
+ (pair? (cdr t)))
+ (append.2 (cadr t) state)
+ state))))
+
+; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
+(define (flatten-left-op op e)
+ (maptree-post (lambda (node)
+ (if (and (pair? node)
+ (eq (car node) op)
+ (pair? (cdr node))
+ (pair? (cadr node))
+ (eq (caadr node) op))
+ (cons op
+ (append (cdadr node) (cddr node)))
+ node))
+ e))
+
+; convert all local variable references to (lexref rib slot name)
+; where rib is the nesting level and slot is the stack slot#
+; name is just there for reference
+; this assumes lambda is the only remaining naming form
+(define (lookup-var v env lev)
+ (if (null? env) v
+ (let ((i (index-of v (car env) 0)))
+ (if i (list 'lexref lev i v)
+ (lookup-var v (cdr env) (+ lev 1))))))
+(define (lvc- e env)
+ (cond ((symbol? e) (lookup-var e env 0))
+ ((pair? e)
+ (if (eq (car e) 'quote)
+ e
+ (let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
+ (newenv (if newvs (cons newvs env) env)))
+ (if newvs
+ (cons 'lambda
+ (cons (cadr e)
+ (map (lambda (se) (lvc- se newenv))
+ (cddr e))))
+ (map (lambda (se) (lvc- se env)) e)))))
+ (#t e)))
+(define (lexical-var-conversion e)
+ (lvc- e ()))
+
+; convert let to lambda
+(define (let-expand e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'let))
+ `((lambda ,(map car (cadr n)) ,@(cddr n))
+ ,@(map cadr (cadr n)))
+ n))
+ e))
+
+; alpha renaming
+; transl is an assoc list ((old-sym-name . new-sym-name) ...)
+(define (alpha-rename e transl)
+ (map&fold e
+ ()
+ ; mapper: replace symbol if unbound
+ (lambda (t env)
+ (if (symbol? t)
+ (let ((found (assq t transl)))
+ (if (and found
+ (not (memq t env)))
+ (cdr found)
+ t))
+ t))
+ ; folder: add locals to environment if entering a new scope
+ (lambda (t env)
+ (if (and (pair? t) (or (eq? (car t) 'let)
+ (eq? (car t) 'lambda)))
+ (append (cadr t) env)
+ env))))
+
+; flatten op with any associativity
+(define-macro (flatten-all-op op e)
+ `(pattern-expand
+ (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
+ (cons ',op (append l (cdr inner) r)))
+ ,e))
+
+(define-macro (pattern-lambda pat body)
+ (let* ((args (patargs pat))
+ (expander `(lambda ,args ,body)))
+ `(lambda (expr)
+ (let ((m (match ',pat expr)))
+ (if m
+ ; matches; perform expansion
+ (apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
+ ',args))
+ #f)))))
--- /dev/null
+++ b/femtolisp/tests/ast/datetimeR.lsp
@@ -1,0 +1,79 @@
+'(r-expressions
+ (<- Sys.time (function () (r-call structure (r-call .Internal (r-call Sys.time)) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
+ (<- Sys.timezone (function () (r-call as.vector (r-call Sys.getenv "TZ")) ()))
+ (<- as.POSIXlt (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- fromchar (function ((*named* x *r-missing*)) (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-call attr res "tzone") 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 (function ((*named* x *r-missing*) (*named* tz "")) (r-call UseMethod "as.POSIXct") ()))
+ (<- as.POSIXct.Date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call structure (r-call * (r-call unclass x) 86400) (*named* class (r-call c "POSIXt" "POSIXct"))) ()))
+ (<- as.POSIXct.date (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* tz "")) (r-block (<- 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 (function ((*named* x *r-missing*) (*named* tz "")) (r-block (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 (function ((*named* x *r-missing*)) (r-call as.POSIXct x) ()))
+ (<- format.POSIXlt (function ((*named* x *r-missing*) (*named* format "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (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 ($ x sec)) (<- 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))) 1e-06)) (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 (function ((*named* x *r-missing*) (*named* format *r-missing*) (*named* tz "")) (r-call .Internal (r-call strptime (r-call as.character x) format tz)) ()))
+ (<- format.POSIXct (function ((*named* x *r-missing*) (*named* format "") (*named* tz "") (*named* usetz *r-false*) (*named* ... *r-missing*)) (r-block (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*) r-dotdotdot) r-dotdotdot) (r-call invisible x)) ()))
+ (<- print.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call print (r-call format x (*named* usetz *r-true*)) r-dotdotdot) (r-call invisible x)) ()))
+ (<- summary.POSIXct (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-block (<- x (r-call r-index (r-call summary.default (r-call unclass object) (*named* digits digits) r-dotdotdot) (r-call : 1 6))) (<- (r-call class x) (r-call oldClass object)) (<- (r-call attr x "tzone") (r-call attr object "tzone")) x) ()))
+ (<- summary.POSIXlt (function ((*named* object *r-missing*) (*named* digits 15) (*named* ... *r-missing*)) (r-call summary (r-call as.POSIXct object) (*named* digits digits) r-dotdotdot) ()))
+ (<- "+.POSIXt" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic " not defined for POSIXt objects")) ()))
+ (<- check_tzones (function ((*named* ... *r-missing*)) (r-block (<- tzs (r-call unique (r-call sapply (r-call list r-dotdotdot) (function ((*named* x *r-missing*)) (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 (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (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-call class val) (r-call oldClass (r-call r-aref args 1))) (<- (r-call attr val "tzone") tz) val) ()))
+ (<- Summary.POSIXlt (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (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" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
+ (<- "[[.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[[")) (<- (r-call class val) cl) (<- (r-call attr val "tzone") (r-call attr x "tzone")) val) ()))
+ (<- "[<-.POSIXct" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* value *r-missing*)) (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-call class x) (<- (r-call class value) ())) (<- x (r-call NextMethod .Generic)) (<- (r-call class x) cl) (<- (r-call attr x "tzone") tz) x) ()))
+ (<- as.character.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call format x r-dotdotdot) ()))
+ (<- as.data.frame.POSIXct as.data.frame.vector)
+ (<- is.na.POSIXlt (function ((*named* x *r-missing*)) (r-call is.na (r-call as.POSIXct x)) ()))
+ (<- c.POSIXct (function ((*named* ... *r-missing*) (*named* 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 (function ((*named* ... *r-missing*) (*named* 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 (function ((*named* target *r-missing*) (*named* current *r-missing*) (*named* ... *r-missing*) (*named* scale 1)) (r-block (r-call check_tzones target current) (r-call NextMethod "all.equal")) ()))
+ (<- ISOdatetime (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour *r-missing*) (*named* min *r-missing*) (*named* sec *r-missing*) (*named* tz "")) (r-block (<- 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 (function ((*named* year *r-missing*) (*named* month *r-missing*) (*named* day *r-missing*) (*named* hour 12) (*named* min 0) (*named* sec 0) (*named* tz "GMT")) (r-call ISOdatetime year month day hour min sec tz) ()))
+ (<- as.matrix.POSIXlt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call as.matrix (r-call as.data.frame (r-call unclass x)) r-dotdotdot)) ()))
+ (<- mean.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call as.POSIXlt (r-call mean (r-call as.POSIXct x) r-dotdotdot)) ()))
+ (<- difftime (function ((*named* time1 *r-missing*) (*named* time2 *r-missing*) (*named* tz "") (*named* units (r-call c "auto" "secs" "mins" "hours" "days" "weeks"))) (r-block (<- 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 (function ((*named* tim *r-missing*) (*named* format "%X") (*named* units "auto")) (r-block (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 (function ((*named* x *r-missing*)) (r-call UseMethod "units") ()))
+ (<- "units<-" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-call UseMethod "units<-") ()))
+ (<- units.difftime (function ((*named* x *r-missing*)) (r-call attr x "units") ()))
+ (<- "units<-.difftime" (function ((*named* x *r-missing*) (*named* value *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* units "auto") (*named* ... *r-missing*)) (r-block (if (r-call != units "auto") (<- (r-call units x) units)) (r-call as.double (r-call as.vector x))) ()))
+ (<- as.data.frame.difftime as.data.frame.vector)
+ (<- format.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call paste (r-call format (r-call unclass x) r-dotdotdot) (r-call units x)) ()))
+ (<- print.difftime (function ((*named* x *r-missing*) (*named* digits (r-call getOption "digits")) (*named* ... *r-missing*)) (r-block (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-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 (function ((*named* x *r-missing*) (*named* digits 0) (*named* ... *r-missing*)) (r-block (<- units (r-call attr x "units")) (r-call structure (r-call NextMethod) (*named* units units) (*named* class "difftime"))) ()))
+ (<- "[.difftime" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- cl (r-call oldClass x)) (<- (r-call class x) ()) (<- val (r-call NextMethod "[")) (<- (r-call class val) cl) (<- (r-call attr val "units") (r-call attr x "units")) val) ()))
+ (<- Ops.difftime (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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-call r-index e1 *r-missing*) (r-call - (r-call unclass e1))))) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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" (function ((*named* e1 *r-missing*) (*named* e2 *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (r-call stop .Generic "not defined for \"difftime\" objects")) ()))
+ (<- mean.difftime (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* na.rm *r-false*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* ... *r-missing*) (*named* na.rm *r-missing*)) (r-block (<- coerceTimeUnit (function ((*named* x *r-missing*)) (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 (function ((*named* from *r-missing*) (*named* to *r-missing*) (*named* by *r-missing*) (*named* length.out ()) (*named* along.with ()) (*named* ... *r-missing*)) (r-block (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 ($ r1 year) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- yr (r-call seq.int ($ r1 year) ($ to year) by)))) (<- ($ r1 year) yr) (<- ($ r1 isdst) (r-call - 1)) (<- res (r-call as.POSIXct r1))) (if (r-call == valid 6) (r-block (if (missing to) (r-block (<- mon (r-call seq.int ($ r1 mon) (*named* by by) (*named* length length.out)))) (r-block (<- to (r-call as.POSIXlt to)) (<- mon (r-call seq.int ($ r1 mon) (r-call + (r-call * 12 (r-call - ($ to year) ($ r1 year))) ($ to mon)) by)))) (<- ($ r1 mon) mon) (<- ($ r1 isdst) (r-call - 1)) (<- 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.POSI
\ No newline at end of file
+ (<- cut.POSIXt (function ((*named* x *r-missing*) (*named* breaks *r-missing*) (*named* labels ()) (*named* start.on.monday *r-true*) (*named* right *r-false*) (*named* ... *r-missing*)) (r-block (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 (<- ($ start sec) 0) (<- incr 59.99))) (if (r-call > valid 2) (r-block (<- ($ start min) 0) (<- incr (r-call - 3600 1)))) (if (r-call > valid 3) (r-block (<- ($ start hour) 0) (<- incr (r-call - 86400 1)))) (if (r-call == valid 5) (r-block (<- ($ start mday) (r-call - ($ start mday) ($ start wday))) (if start.on.monday (<- ($ start mday) (r-call + ($ start mday) (r-call ifelse (r-call > ($ start wday) 0) 1 (r-call - 6))))) (<- incr (r-call * 7 86400)))) (if (r-call == valid 6) (r-block (<- ($ start mday) 1) (<- incr (r-call * 31 86400)))) (if (r-call == valid 7) (r-block (<- ($ start mon) 0) (<- ($ start mday) 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-call levels res) (r-call as.character (r-call r-index breaks (r-call - (r-call length breaks)))))) res) ()))
+ (<- julian (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-call UseMethod "julian") ()))
+ (<- julian.POSIXt (function ((*named* x *r-missing*) (*named* origin (r-call as.POSIXct "1970-01-01" (*named* tz "GMT"))) (*named* ... *r-missing*)) (r-block (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 (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "weekdays") ()))
+ (<- weekdays.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%a" "%A"))) ()))
+ (<- months (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "months") ()))
+ (<- months.POSIXt (function ((*named* x *r-missing*) (*named* abbreviate *r-false*)) (r-block (r-call format x (r-call ifelse abbreviate "%b" "%B"))) ()))
+ (<- quarters (function ((*named* x *r-missing*) (*named* abbreviate *r-missing*)) (r-call UseMethod "quarters") ()))
+ (<- quarters.POSIXt (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- x (r-call %/% ($ (r-call as.POSIXlt x) mon) 3)) (r-call paste "Q" (r-call + x 1) (*named* sep ""))) ()))
+ (<- trunc.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (<- units (r-call match.arg units)) (<- x (r-call as.POSIXlt x)) (if (r-call > (r-call length ($ x sec)) 0) (switch units (*named* secs (r-block (<- ($ x sec) (r-call trunc ($ x sec))))) (*named* mins (r-block (<- ($ x sec) 0))) (*named* hours (r-block (<- ($ x sec) 0) (<- ($ x min) 0))) (*named* days (r-block (<- ($ x sec) 0) (<- ($ x min) 0) (<- ($ x hour) 0) (<- ($ x isdst) (r-call - 1)))))) x) ()))
+ (<- round.POSIXt (function ((*named* x *r-missing*) (*named* units (r-call c "secs" "mins" "hours" "days"))) (r-block (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" (function ((*named* x *r-missing*) (*named* ... *r-missing*) (*named* drop *r-true*)) (r-block (<- val (r-call lapply x "[" r-dotdotdot (*named* drop drop))) (<- (r-call attributes val) (r-call attributes x)) val) ()))
+ (<- "[<-.POSIXlt" (function ((*named* x *r-missing*) (*named* i *r-missing*) (*named* value *r-missing*)) (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-call class x) (<- (r-call class value) ())) (for n (r-call names x) (<- (r-call r-index (r-call r-aref x n) i) (r-call r-aref value n))) (<- (r-call class x) cl) x) ()))
+ (<- as.data.frame.POSIXlt (function ((*named* x *r-missing*) (*named* row.names ()) (*named* optional *r-false*) (*named* ... *r-missing*)) (r-block (<- value (r-call as.data.frame.POSIXct (r-call as.POSIXct x) row.names optional r-dotdotdot)) (if (r-call ! optional) (<- (r-call names value) (r-call r-aref (r-call deparse (substitute x)) 1))) value) ()))
+ (<- rep.POSIXct (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (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 (function ((*named* x *r-missing*) (*named* ... *r-missing*)) (r-block (<- y (r-call lapply x rep r-dotdotdot)) (<- (r-call attributes y) (r-call attributes x)) y) ()))
+ (<- diff.POSIXt (function ((*named* x *r-missing*) (*named* lag 1) (*named* differences 1) (*named* ... *r-missing*)) (r-block (<- 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 (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-block (<- x (r-call as.POSIXct x)) (r-call NextMethod "duplicated" x)) ()))
+ (<- unique.POSIXlt (function ((*named* x *r-missing*) (*named* incomparables *r-false*) (*named* ... *r-missing*)) (r-call r-index x (r-call ! (r-call duplicated x incomparables r-dotdotdot))) ()))
+ (<- sort.POSIXlt (function ((*named* x *r-missing*) (*named* decreasing *r-false*) (*named* na.last NA) (*named* ... *r-missing*)) (r-call r-index x (r-call order (r-call as.POSIXct x) (*named* na.last na.last) (*named* decreasing decreasing))) ())))
--- /dev/null
+++ b/femtolisp/tests/ast/match.lsp
@@ -1,0 +1,181 @@
+; -*- scheme -*-
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+(define (unique lst)
+ (if (null? lst)
+ ()
+ (cons (car lst)
+ (filter (lambda (x) (not (eq x (car lst))))
+ (unique (cdr lst))))))
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbol? p)
+ (cond ((eq p '_) state)
+ (#t
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((procedure? p)
+ (and (p expr) state))
+
+ ((pair? p)
+ (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq (car p) '--)
+ (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 #f 1))
+ (#t
+ (and (pair? expr)
+ (equal? (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (#t
+ (and (equal? p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null? alt) #f ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) #f)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (#t
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+(define (match-star p prest expr state var min max L)
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) #f)
+ ((null? p) (if (null? expr) state #f))
+ (#t
+ (let ((subp (car p))
+ (var #f))
+ (if (and (pair? subp)
+ (eq (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ #f)
+ (let ((head (if (pair? subp) (car subp) ())))
+ (cond ((eq subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (#t
+ (and (pair? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs- p)
+ (cond ((and (symbol? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((pair? p)
+ (if (eq (car p) '-/)
+ ()
+ (unique (apply append (map patargs- (cdr p))))))
+
+ (#t ())))
+(define (patargs p)
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null? plist) expr
+ (if (procedure? plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (pair? expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/femtolisp/tests/ast/match.scm
@@ -1,0 +1,174 @@
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+; list of special pattern symbols that cannot be variable names
+(define metasymbols '(_ ...))
+
+; expression tree pattern matching
+; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
+; mapping variables to captured subexpressions, or #f if no match.
+; when a match succeeds, __ is always bound to the whole matched expression.
+;
+; p is an expression in the following pattern language:
+;
+; _ match anything, not captured
+; <func> any scheme function; matches if (func expr) returns #t
+; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
+; must match the same thing.
+; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
+; subpatterns matched recursively.
+; (-/ <ex>) match <ex> literally
+; (-^ <p>) complement of pattern <p>
+; (-- <var> <p>) match <p> and capture as <var> if match succeeds
+;
+; regular match constructs:
+; ... match any number of anything
+; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
+; (-* <p>) match any number of <p>
+; (-? <p>) match 0 or 1 of <p>
+; (-+ <p>) match at least 1 of <p>
+; all of these can be wrapped in (-- var ) for capturing purposes
+; This is NP-complete. Be careful.
+;
+(define (match- p expr state)
+ (cond ((symbol? p)
+ (cond ((eq? p '_) state)
+ (else
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((procedure? p)
+ (and (p expr) state))
+
+ ((pair? p)
+ (cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ ((eq? (car p) '--)
+ (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 #f 1))
+ (else
+ (and (pair? expr)
+ (equal? (car p) (car expr))
+ (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
+
+ (else
+ (and (equal? p expr) state))))
+
+; match an alternation
+(define (match-alt alt prest expr state var L)
+ (if (null? alt) #f ; no alternatives left
+ (let ((subma (match- (car alt) (car expr) state)))
+ (or (and subma
+ (match-seq prest (cdr expr)
+ (if var
+ (cons (cons var (car expr))
+ subma)
+ subma)
+ (- L 1)))
+ (match-alt (cdr alt) prest expr state var L)))))
+
+; match generalized kleene star (try consuming min to max)
+(define (match-star p prest expr state var min max L)
+ (define (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) #f)
+ ; case 1: only allowed to match 0 subexpressions
+ ((= max 0) (match-seq prest expr
+ (if var (cons (cons var (reverse sofar)) state)
+ state)
+ L))
+ ; case 2: must match at least 1
+ ((> min 0)
+ (and (match- p (car expr) state)
+ (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
+ (cons (car expr) sofar))))
+ ; otherwise, must match either 0 or between 1 and max subexpressions
+ (else
+ (or (match-star- p prest expr state var 0 0 L sofar)
+ (match-star- p prest expr state var 1 max L sofar)))))
+
+ (match-star- p prest expr state var min max L ()))
+
+; match sequences of expressions
+(define (match-seq p expr state L)
+ (cond ((not state) #f)
+ ((null? p) (if (null? expr) state #f))
+ (else
+ (let ((subp (car p))
+ (var #f))
+ (if (and (pair? subp)
+ (eq? (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ #f)
+ (let ((head (if (pair? subp) (car subp) ())))
+ (cond ((eq? subp '...)
+ (match-star '_ (cdr p) expr state var 0 L L))
+ ((eq? head '-*)
+ (match-star (cadr subp) (cdr p) expr state var 0 L L))
+ ((eq? head '-+)
+ (match-star (cadr subp) (cdr p) expr state var 1 L L))
+ ((eq? head '-?)
+ (match-star (cadr subp) (cdr p) expr state var 0 1 L))
+ ((eq? head '-$)
+ (match-alt (cdr subp) (cdr p) expr state var L))
+ (else
+ (and (pair? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(define (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(define (patargs p)
+ (define (patargs- p)
+ (cond ((and (symbol? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((pair? p)
+ (if (eq? (car p) '-/)
+ ()
+ (delete-duplicates (apply append (map patargs- (cdr p))))))
+
+ (else ())))
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(define (apply-patterns plist expr)
+ (if (null? plist) expr
+ (if (procedure? plist)
+ (let ((enew (plist expr)))
+ (if (not enew)
+ expr
+ enew))
+ (let ((enew ((car plist) expr)))
+ (if (not enew)
+ (apply-patterns (cdr plist) expr)
+ enew)))))
+
+; top-down fixed-point macroexpansion. this is a typical algorithm,
+; but it may leave some structure that matches a pattern unexpanded.
+; the advantage is that non-terminating cases cannot arise as a result
+; of expression composition. in other words, if the outer loop terminates
+; on all inputs for a given set of patterns, then the whole algorithm
+; terminates. pattern sets that violate this should be easier to detect,
+; for example
+; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
+; TODO: ignore quoted expressions
+(define (pattern-expand plist expr)
+ (if (not (pair? expr))
+ expr
+ (let ((enew (apply-patterns plist expr)))
+ (if (eq? enew expr)
+ ; expr didn't change; move to subexpressions
+ (cons (car expr)
+ (map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
+ ; expr changed; iterate
+ (pattern-expand plist enew)))))
--- /dev/null
+++ b/femtolisp/tests/ast/rpasses-out.lsp
@@ -1,0 +1,1701 @@
+'(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 ())
+ (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 "")
+ (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 ())
+ (usetz ())
+ (tz ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format ""))
+ (when (missing tz)
+ (<- tz ""))
+ (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")))))
+ (<- 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 ((tz ())
+ (sec ())
+ (min ())
+ (hour ()))
+ (r-block (when (missing hour)
+ (<- hour 12))
+ (when (missing min)
+ (<- min 0))
+ (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
+ 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 ())
+ (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
+ (*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 ((units ())
+ (format ()))
+ (r-block (when (missing format)
+ (<- format "%X"))
+ (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
+ 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 ())
+ (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
+ 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 ())
+ (right ())
+ (start.on.monday ())
+ (labels ()))
+ (r-block (when (missing labels)
+ (<- labels ()))
+ (when (missing start.on.monday)
+ (<- start.on.monday
+ *r-true*))
+ (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")
+ (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 ())
+ (optional ())
+ (row.names ()))
+ (r-block (when (missing
+ row.names)
+ (<- row.names ()))
+ (when (missing
+ optional)
+ (<- optional
+ *r-false*))
+ (<- 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 ())
+ (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-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 ((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)
+ (*named*
+ na.last
+ na.last)
+ (*named*
+ decreasing
+ decreasing))))))))
--- /dev/null
+++ b/femtolisp/tests/ast/rpasses.lsp
@@ -1,0 +1,110 @@
+; -*- scheme -*-
+(load "match.lsp")
+(load "asttools.lsp")
+
+(define missing-arg-tag '*r-missing*)
+
+; tree inspection utils
+
+(define (assigned-var e)
+ (and (pair? e)
+ (or (eq (car e) '<-) (eq (car e) 'ref=))
+ (symbol? (cadr e))
+ (cadr e)))
+
+(define (func-argnames f)
+ (let ((argl (cadr f)))
+ (if (eq argl '*r-null*) ()
+ (map cadr argl))))
+
+; transformations
+
+(let ((ctr 0))
+ (set! r-gensym (lambda ()
+ (prog1 (symbol (string "%r:" ctr))
+ (set! ctr (+ ctr 1))))))
+
+(define (dollarsign-transform e)
+ (pattern-expand
+ (pattern-lambda ($ lhs name)
+ (let* ((g (if (not (pair? lhs)) lhs (r-gensym)))
+ (n (if (symbol? name)
+ name ;(symbol->string name)
+ name))
+ (expr `(r-call
+ r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
+ (if (not (pair? lhs))
+ expr
+ `(r-block (ref= ,g ,lhs) ,expr))))
+ e))
+
+; lower r expressions of the form f(lhs,...) <- rhs
+; TODO: if there are any special forms that can be f in this expression,
+; they need to be handled separately. For example a$b can be lowered
+; to an index assignment (by dollarsign-transform), after which
+; this transform applies. I don't think there are any others though.
+(define (fancy-assignment-transform e)
+ (pattern-expand
+ (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
+ (<<- (r-call f lhs ...) rhs))
+ (let ((g (if (pair? rhs) (r-gensym) rhs))
+ (op (car __)))
+ `(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
+ (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
+ ,g)))
+ e))
+
+; map an arglist with default values to appropriate init code
+; function(x=blah) { ... } gets+; if (missing(x)) x = blah
+; added to its body
+(define (gen-default-inits arglist)
+ (map (lambda (arg)
+ (let ((name (cadr arg))
+ (default (caddr arg)))
+ `(when (missing ,name)
+ (<- ,name ,default))))
+ (filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
+
+; convert r function expressions to lambda
+(define (normalize-r-functions e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'function))
+ `(lambda ,(func-argnames n)
+ (r-block ,@(gen-default-inits (cadr n))
+ ,@(if (and (pair? (caddr n))
+ (eq (car (caddr n)) 'r-block))
+ (cdr (caddr n))
+ (list (caddr n)))))
+ n))
+ e))
+
+(define (find-assigned-vars n)
+ (let ((vars ()))
+ (maptree-pre (lambda (s)
+ (if (not (pair? s)) s
+ (cond ((eq (car s) 'lambda) ())
+ ((eq (car s) '<-)
+ (set! vars (list-adjoin (cadr s) vars))
+ (cddr s))
+ (#t s))))
+ n)
+ vars))
+
+; introduce let based on assignment statements
+(define (letbind-locals e)
+ (maptree-post (lambda (n)
+ (if (and (pair? n) (eq (car n) 'lambda))
+ (let ((vars (find-assigned-vars (cddr n))))
+ `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
+ vars)
+ ,@(cddr n))))
+ n))
+ e))
+
+(define (compile-ish e)
+ (letbind-locals
+ (normalize-r-functions
+ (fancy-assignment-transform
+ (dollarsign-transform
+ (flatten-all-op && (flatten-all-op \|\| e)))))))