moving stuff around some more

tests/ast/asttools.lsp

@@ -0,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)))))

tests/ast/datetimeR.lsp

@@ -0,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.POSIXct from))) 86400)))))) (<- ($ r1 mday) (r-call seq.int ($ r1 mday) (*named* by by) (*named* length length.out))) (<- ($ r1 isdst) (r-call - 1)) (<- 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 (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))) ())))

tests/ast/match.lsp

@@ -0,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)))))

tests/ast/match.scm

@@ -0,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)))))

tests/ast/rpasses.lsp

@@ -0,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)))))))