ref: ebc07a3b8f4ab9bc0e0eb44f1797461bc616f455
parent: 63647b5d871fe95713a88c18324782f84c4b88dc
author: Sigrid Solveig Haflínudóttir <[email protected]>
date: Wed Mar 8 15:45:55 EST 2023
more fixes, "test" mk target
--- a/Makefile
+++ b/Makefile
@@ -20,7 +20,7 @@
default: release test
test:
- cd tests && ../flisp unittest.lsp
+ cd test && ../flisp unittest.lsp
%.o: %.c
$(CC) $(SHIPFLAGS) -c $< -o $@
--- a/builtins.c
+++ b/builtins.c
@@ -285,15 +285,13 @@
else
return args[0];
- d = trunc(d);
-
if (d > 0) {- if (d > S64_MAX)
- return mk_double(d);
+ if (d > (double)S64_MAX)
+ return args[0];
return return_from_uint64((uint64_t)d);
}
- if (d > S64_MAX || d < S64_MIN)
- return mk_double(d);
+ if (d > (double)S64_MAX || d < (double)S64_MIN)
+ return args[0];
return return_from_int64((int64_t)d);
}
type_error("truncate", "number", args[0]);@@ -383,10 +381,8 @@
argcount("path.exists?", nargs, 1);char *str = tostring(args[0], "path.exists?");
#ifdef __plan9__
- Dir *d;
- if ((d = dirstat(str)) == nil)
+ if (access(str, 0) != 0)
return FL_F;
- free(d);
#else
struct stat sbuf;
if (stat(str, &sbuf) == -1)
--- a/cvalues.c
+++ b/cvalues.c
@@ -307,7 +307,7 @@
num_ctor(uint64, uint64, T_UINT64)
num_ctor(byte, uint8, T_UINT8)
num_ctor(wchar, int32, T_INT32)
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
num_ctor(long, int64, T_INT64)
num_ctor(ulong, uint64, T_UINT64)
#else
@@ -553,7 +553,7 @@
return 8;
}
if (type == longsym || type == ulongsym) {-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
*palign = ALIGN8;
return 8;
#else
@@ -740,25 +740,25 @@
return T_INT16;
else if (type == uint16sym)
return T_UINT16;
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
else if (type == int32sym || type == wcharsym)
#else
else if (type == int32sym || type == wcharsym || type == longsym)
#endif
return T_INT32;
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
else if (type == uint32sym)
#else
else if (type == uint32sym || type == ulongsym)
#endif
return T_UINT32;
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
else if (type == int64sym || type == longsym)
#else
else if (type == int64sym)
#endif
return T_INT64;
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
else if (type == uint64sym || type == ulongsym)
#else
else if (type == uint64sym)
@@ -991,7 +991,7 @@
mk_primtype(uint32);
mk_primtype(int64);
mk_primtype(uint64);
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
mk_primtype_(long,int64);
mk_primtype_(ulong,uint64);
#else
--- a/flisp.h
+++ b/flisp.h
@@ -58,7 +58,7 @@
#define tagptr(p,t) (((value_t)(p)) | (t))
#define fixnum(x) ((value_t)(((fixnum_t)(x))<<2))
#define numval(x) (((fixnum_t)(x))>>2)
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
#define fits_fixnum(x) (((x)>>61) == 0 || (~((x)>>61)) == 0)
#else
#define fits_fixnum(x) (((x)>>29) == 0 || (~((x)>>29)) == 0)
@@ -220,7 +220,7 @@
#define N_NUMTYPES ((int)T_DOUBLE+1)
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
# define T_LONG T_INT64
# define T_ULONG T_UINT64
#else
@@ -378,7 +378,7 @@
uint64_t conv_to_uint64(void *data, numerictype_t tag);
int32_t conv_to_int32(void *data, numerictype_t tag);
uint32_t conv_to_uint32(void *data, numerictype_t tag);
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
#define conv_to_long conv_to_int64
#define conv_to_ulong conv_to_uint64
#else
--- a/llt/dtypes.h
+++ b/llt/dtypes.h
@@ -114,13 +114,8 @@
typedef int bool_t;
#if defined(__plan9__)
-#ifdef BITS64
-typedef uvlong size_t;
-typedef vlong ssize_t;
-#else
typedef ulong size_t;
typedef long ssize_t;
-#endif
#define STATIC_INLINE static
#define INLINE
#ifndef NULL
@@ -216,6 +211,7 @@
#define S32_MIN (-S32_MAX - 1L)
#define BIT31 0x80000000
+#ifndef DBL_EPSILON
#define DBL_EPSILON 2.2204460492503131e-16
#define FLT_EPSILON 1.192092896e-7
#if !defined(NETBSD)
@@ -224,6 +220,8 @@
#define FLT_MAX 3.402823466e+38
#define FLT_MIN 1.175494351e-38
#endif
+#endif
+
#define LOG2_10 3.3219280948873626
#define rel_zero(a, b) (fabs((a)/(b)) < DBL_EPSILON)
#define sign_bit(r) ((*(int64_t*)&(r)) & BIT63)
--- a/print.c
+++ b/print.c
@@ -699,7 +699,7 @@
}
}
else if (type == uint64sym
-#ifdef BITS64
+#if defined(BITS64) && !defined(__plan9__)
|| type == ulongsym
#endif
) {--- a/read.c
+++ b/read.c
@@ -274,7 +274,7 @@
else
lerror(ParseError, "read: invalid label");
errno = 0;
- x = strtol(buf, &end, 10);
+ x = strtoll(buf, &end, 10);
if (*end != '\0' || errno)
lerror(ParseError, "read: invalid label");
tokval = fixnum(x);
--- /dev/null
+++ b/test/100x100.lsp
@@ -1,0 +1,1 @@
+'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- /dev/null
+++ b/test/argv.lsp
@@ -1,0 +1,1 @@
+(print *argv*) (princ "\n")
--- /dev/null
+++ b/test/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/test/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/test/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/test/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/test/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/test/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)))))))
--- /dev/null
+++ b/test/color.lsp
@@ -1,0 +1,89 @@
+; -*- scheme -*-
+
+; dictionaries ----------------------------------------------------------------
+(define (dict-new) ())
+
+(define (dict-extend dl key value)
+ (cond ((null? dl) (list (cons key value)))
+ ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
+ (else (cons (car dl) (dict-extend (cdr dl) key value)))))
+
+(define (dict-lookup dl key)
+ (cond ((null? dl) ())
+ ((equal? key (caar dl)) (cdar dl))
+ (else (dict-lookup (cdr dl) key))))
+
+(define (dict-keys dl) (map car dl))
+
+; graphs ----------------------------------------------------------------------
+(define (graph-empty) (dict-new))
+
+(define (graph-connect g n1 n2)
+ (dict-extend
+ (dict-extend g n2 (cons n1 (dict-lookup g n2)))
+ n1
+ (cons n2 (dict-lookup g n1))))
+
+(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+
+(define (graph-neighbors g n) (dict-lookup g n))
+
+(define (graph-nodes g) (dict-keys g))
+
+(define (graph-add-node g n1) (dict-extend g n1 ()))
+
+(define (graph-from-edges edge-list)
+ (if (null? edge-list)
+ (graph-empty)
+ (graph-connect (graph-from-edges (cdr edge-list))
+ (caar edge-list)
+ (cdar edge-list))))
+
+; graph coloring --------------------------------------------------------------
+(define (node-colorable? g coloring node-to-color color-of-node)
+ (not (member
+ color-of-node
+ (map
+ (lambda (n)
+ (let ((color-pair (assq n coloring)))
+ (if (pair? color-pair) (cdr color-pair) ())))
+ (graph-neighbors g node-to-color)))))
+
+(define (try-each f lst)
+ (if (null? lst) #f
+ (let ((ret (f (car lst))))
+ (if ret ret (try-each f (cdr lst))))))
+
+(define (color-node g coloring colors uncolored-nodes color)
+ (cond
+ ((null? uncolored-nodes) coloring)
+ ((node-colorable? g coloring (car uncolored-nodes) color)
+ (let ((new-coloring
+ (cons (cons (car uncolored-nodes) color) coloring)))
+ (try-each (lambda (c)
+ (color-node g new-coloring colors (cdr uncolored-nodes) c))
+ colors)))))
+
+(define (color-graph g colors)
+ (if (null? colors)
+ (and (null? (graph-nodes g)) ())
+ (color-node g () colors (graph-nodes g) (car colors))))
+
+(define (color-pairs pairs colors)
+ (color-graph (graph-from-edges pairs) colors))
+
+; queens ----------------------------------------------------------------------
+(define (can-attack x y)
+ (let ((x1 (mod x 5))
+ (y1 (truncate (/ x 5)))
+ (x2 (mod y 5))
+ (y2 (truncate (/ y 5))))
+ (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
+
+(define (generate-5x5-pairs)
+ (let ((result ()))
+ (dotimes (x 25)
+ (dotimes (y 25)
+ (if (and (not (= x y)) (can-attack x y))
+ (set! result (cons (cons x y) result)) ())))
+ result))
--- /dev/null
+++ b/test/equal.scm
@@ -1,0 +1,68 @@
+; Terminating equal predicate
+; by Jeff Bezanson
+;
+; This version only considers pairs and simple atoms.
+
+; equal?, with bounded recursion. returns 0 if we suspect
+; nontermination, otherwise #t or #f for the correct answer.
+(define (bounded-equal a b N)
+ (cond ((<= N 0) 0)
+ ((and (pair? a) (pair? b))
+ (let ((as
+ (bounded-equal (car a) (car b) (- N 1))))
+ (if (number? as)
+ 0
+ (and as
+ (bounded-equal (cdr a) (cdr b) (- N 1))))))
+ (else (eq? a b))))
+
+; union-find algorithm
+
+; find equivalence class of a cons cell, or #f if not yet known
+; the root of a class is a cons that is its own class
+(define (class table key)
+ (let ((c (hashtable-ref table key #f)))
+ (if (or (not c) (eq? c key))
+ c
+ (class table c))))
+
+; move a and b to the same equivalence class, given c and cb
+; as the current values of (class table a) and (class table b)
+; Note: this is not quite optimal. We blindly pick 'a' as the
+; root of the new class, but we should pick whichever class is
+; larger.
+(define (union! table a b c cb)
+ (let ((ca (if c c a)))
+ (if cb
+ (hashtable-set! table cb ca))
+ (hashtable-set! table a ca)
+ (hashtable-set! table b ca)))
+
+; cyclic equal. first, attempt to compare a and b as best
+; we can without recurring. if we can't prove them different,
+; set them equal and move on.
+(define (cyc-equal a b table)
+ (cond ((eq? a b) #t)
+ ((not (and (pair? a) (pair? b))) (eq? a b))
+ (else
+ (let ((aa (car a)) (da (cdr a))
+ (ab (car b)) (db (cdr b)))
+ (cond ((or (not (eq? (atom? aa) (atom? ab)))
+ (not (eq? (atom? da) (atom? db)))) #f)
+ ((and (atom? aa)
+ (not (eq? aa ab))) #f)
+ ((and (atom? da)
+ (not (eq? da db))) #f)
+ (else
+ (let ((ca (class table a))
+ (cb (class table b)))
+ (if (and ca cb (eq? ca cb))
+ #t
+ (begin (union! table a b ca cb)
+ (and (cyc-equal aa ab table)
+ (cyc-equal da db table)))))))))))
+
+(define (equal a b)
+ (let ((guess (bounded-equal a b 2048)))
+ (if (boolean? guess) guess
+ (cyc-equal a b (make-eq-hashtable)))))
--- /dev/null
+++ b/test/err.lsp
@@ -1,0 +1,4 @@
+(define (f x) (begin (list-tail '(1) 3) 3))
+(f 2)
+a
+(trycatch a (lambda (e) (print (stacktrace))))
--- /dev/null
+++ b/test/hashtest.lsp
@@ -1,0 +1,40 @@
+; -*- scheme -*-
+
+(define (hins1)
+ (let ((h (table)))
+ (dotimes (n 200000)
+ (put! h (mod (rand) 1000) 'apple))
+ h))
+
+(define (hread h)
+ (dotimes (n 200000)
+ (get h (mod (rand) 10000) nil)))
+
+(time (dotimes (i 100000)
+ (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4)))
+(time (dotimes (i 100000) (table :a 1 :b 2)))
+(time (dotimes (i 100000) (table)))
+
+#t
+
+#|
+
+with HT_N_INLINE==16
+Elapsed time: 0.0796329975128174 seconds
+Elapsed time: 0.0455679893493652 seconds
+Elapsed time: 0.0272290706634521 seconds
+Elapsed time: 0.0177979469299316 seconds
+Elapsed time: 0.0102229118347168 seconds
+
+
+with HT_N_INLINE==8
+
+Elapsed time: 0.1010119915008545 seconds
+Elapsed time: 0.174872875213623 seconds
+Elapsed time: 0.0322129726409912 seconds
+Elapsed time: 0.0195930004119873 seconds
+Elapsed time: 0.008836030960083 seconds
+
+|#
--- /dev/null
+++ b/test/mkfile
@@ -1,0 +1,2 @@
+test:QV:
+ ../$O.out unittest.lsp
--- /dev/null
+++ b/test/perf.lsp
@@ -1,0 +1,37 @@
+(load "test.lsp")
+
+(princ "colorgraph: ")
+(load "tcolor.lsp")
+
+(princ "fib(34): ")
+(assert (equal? (time (fib 34)) 5702887))
+(princ "yfib(32): ")
+(assert (equal? (time (yfib 32)) 2178309))
+
+(princ "sort: ")
+(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
+(time (simple-sort r))
+
+(princ "expand: ")
+(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
+
+(define (my-append . lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (else (letrec ((append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
+
+(princ "append: ")
+(set! L (map-int (lambda (x) (map-int identity 20)) 20))
+(time (dotimes (n 1000) (apply my-append L)))
+
+(path.cwd "ast")
+(princ "p-lambda: ")
+(load "rpasses.lsp")
+(define *input* (load "datetimeR.lsp"))
+(time (set! *output* (compile-ish *input*)))
+(assert (equal? *output* (load "rpasses-out.lsp")))
+(path.cwd "..")
--- /dev/null
+++ b/test/pisum.lsp
@@ -1,0 +1,8 @@
+(define (pisum)
+ (dotimes (j 500)
+ ((label sumloop
+ (lambda (i sum)
+ (if (> i 10000)
+ sum
+ (sumloop (+ i 1) (+ sum (/ (* i i)))))))
+ 1.0 0.0)))
--- /dev/null
+++ b/test/printcases.lsp
@@ -1,0 +1,26 @@
+expand
+append
+bq-process
+
+(define (syntax-environment)
+ (map (lambda (s) (cons s (symbol-syntax s)))
+ (filter symbol-syntax (environment))))
+
+(syntax-environment)
+
+(symbol-syntax 'try)
+
+(map-int (lambda (x) `(a b c d e)) 90)
+
+(list->vector (map-int (lambda (x) `(a b c d e)) 90))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
+
+'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))
--- /dev/null
+++ b/test/tcolor.lsp
@@ -1,0 +1,16 @@
+; -*- scheme -*-
+; color for performance
+
+(load "color.lsp")
+
+; 100x color 5 queens
+(define Q (generate-5x5-pairs))
+(define (ct)
+ (set! C (color-pairs Q '(a b c d e)))
+ (dotimes (n 99) (color-pairs Q '(a b c d e))))
+(time (ct))
+(assert (equal? C
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
--- /dev/null
+++ b/test/test.lsp
@@ -1,0 +1,294 @@
+; -*- scheme -*-
+
+; make label self-evaluating, but evaluating the lambda in the process
+;(defmacro labl (name f)
+; (list list ''labl (list 'quote name) f))
+
+(define-macro (labl name f)
+ `(let (,name) (set! ,name ,f)))
+
+;(define (reverse lst)
+; ((label rev-help (lambda (lst result)
+; (if (null? lst) result
+; (rev-help (cdr lst) (cons (car lst) result)))))
+; lst ()))
+
+(define (append- . lsts)
+ ((label append-h
+ (lambda (lsts)
+ (cond ((null? lsts) ())
+ ((null? (cdr lsts)) (car lsts))
+ (#t ((label append2 (lambda (l d)
+ (if (null? l) d
+ (cons (car l)
+ (append2 (cdr l) d)))))
+ (car lsts) (append-h (cdr lsts)))))))
+ lsts))
+
+;(princ 'Hello '| | 'world! "\n")
+;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+;(princ (time (fib 34)) "\n")
+;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
+;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
+;(dotimes (i 80000) (list 1 2 3 4 5))
+;(set! a (map-int identity 10000))
+;(dotimes (i 200) (rfoldl cons () a))
+
+#|
+(define-macro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(let ((,v 0))
+ (while (< ,v ,cnt)
+ (prog1
+ ,(cons 'begin body)
+ (set! ,v (+ ,v 1)))))))
+
+(define (map-int f n)
+ (if (<= n 0)
+ ()
+ (let ((first (cons (f 0) ())))
+ ((label map-int-
+ (lambda (acc i n)
+ (if (= i n)
+ first
+ (begin (set-cdr! acc (cons (f i) ()))
+ (map-int- (cdr acc) (+ i 1) n)))))
+ first 1 n))))
+|#
+
+(define-macro (labl name fn)
+ `((lambda (,name) (set! ,name ,fn)) ()))
+
+(define (square x) (* x x))
+(define (expt b p)
+ (cond ((= p 0) 1)
+ ((= b 0) 0)
+ ((even? p) (square (expt b (div0 p 2))))
+ (#t (* b (expt b (- p 1))))))
+
+(define (gcd a b)
+ (cond ((= a 0) b)
+ ((= b 0) a)
+ ((< a b) (gcd a (- b a)))
+ (#t (gcd b (- a b)))))
+
+; like eval-when-compile
+(define-macro (literal expr)
+ (let ((v (eval expr)))
+ (if (self-evaluating? v) v (list quote v))))
+
+(define (cardepth l)
+ (if (atom? l) 0
+ (+ 1 (cardepth (car l)))))
+
+(define (nestlist f zero n)
+ (if (<= n 0) ()
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(define (mapl f . lsts)
+ ((label mapl-
+ (lambda (lsts)
+ (if (null? (car lsts)) ()
+ (begin (apply f lsts) (mapl- (map cdr lsts))))))
+ lsts))
+
+; test to see if a symbol begins with :
+(define (keywordp s)
+ (and (>= s '|:|) (<= s '|:~|)))
+
+; swap the cars and cdrs of every cons in a structure
+(define (swapad c)
+ (if (atom? c) c
+ (set-cdr! c (K (swapad (car c))
+ (set-car! c (swapad (cdr c)))))))
+
+(define (without x l)
+ (filter (lambda (e) (not (eq e x))) l))
+
+(define (conscount c)
+ (if (pair? c) (+ 1
+ (conscount (car c))
+ (conscount (cdr c)))
+ 0))
+
+; _ Welcome to
+; (_ _ _ |_ _ | . _ _ 2
+; | (-||||_(_)|__|_)|_)
+; ==================|==
+
+;[` _ ,_ |- | . _ 2
+;| (/_||||_()|_|_\|)
+; |
+
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+; this would be a cool use of thunking to handle 'finally' clauses, but
+; this code doesn't work in the case where the user manually re-raises
+; inside a catch block. one way to handle it would be to replace all
+; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
+; (try expr
+; (catch (TypeError e) . exprs)
+; (catch (IOError e) . exprs)
+; (finally . exprs))
+(define-macro (try expr . forms)
+ (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
+ (body (foldr
+ ; create a function to check for and handle one exception
+ ; type, and pass off control to the next when no match
+ (lambda (catc next)
+ (let ((var (cadr (cadr catc)))
+ (extype (caadr catc))
+ (todo (f-body (cddr catc))))
+ `(lambda (,var)
+ (if (or (eq ,var ',extype)
+ (and (pair? ,var)
+ (eq (car ,var) ',extype)))
+ ,todo
+ (,next ,var)))))
+
+ ; default function; no matches so re-raise
+ '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
+
+ ; make list of catch forms
+ (filter (lambda (f) (eq (car f) 'catch)) forms))))
+ `(let ((*_try_finally_thunk_* (lambda () ,final)))
+ (prog1 (attempt ,expr ,body)
+ (*_try_finally_thunk_*)))))
+
+(define Y
+ (lambda (f)
+ ((lambda (h)
+ (f (lambda (x) ((h h) x))))
+ (lambda (h)
+ (f (lambda (x) ((h h) x)))))))
+
+(define yfib
+ (Y (lambda (fib)
+ (lambda (n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
+
+;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
+;(tt)
+;(tt)
+;(tt)
+
+(define-macro (accumulate-while cnd what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (while ,cnd
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body)))))))
+
+(define-macro (accumulate-for var lo hi what . body)
+ (let ((acc (gensym)))
+ `(let ((,acc (list ())))
+ (cdr
+ (prog1 ,acc
+ (for ,lo ,hi
+ (lambda (,var)
+ (begin (set! ,acc
+ (cdr (set-cdr! ,acc (cons ,what ()))))
+ ,@body))))))))
+
+(define (map-indexed f lst)
+ (if (atom? lst) lst
+ (let ((i 0))
+ (accumulate-while (pair? lst) (f (car lst) i)
+ (begin (set! lst (cdr lst))
+ (set! i (1+ i)))))))
+
+(define (string.findall haystack needle . offs)
+ (define (sub h n offs lst)
+ (let ((i (string.find h n offs)))
+ (if i
+ (sub h n (string.inc h i) (cons i lst))
+ (reverse! lst))))
+ (sub haystack needle (if (null? offs) 0 (car offs)) ()))
+
+(let ((*profiles* (table)))
+ (set! profile
+ (lambda (s)
+ (let ((f (top-level-value s)))
+ (put! *profiles* s (cons 0 0))
+ (set-top-level-value! s
+ (lambda args
+ (define tt (get *profiles* s))
+ (define count (car tt))
+ (define time (cdr tt))
+ (define t0 (time.now))
+ (define v (apply f args))
+ (set-cdr! tt (+ time (- (time.now) t0)))
+ (set-car! tt (+ count 1))
+ v)))))
+ (set! show-profiles
+ (lambda ()
+ (define pr (filter (lambda (x) (> (cadr x) 0))
+ (table.pairs *profiles*)))
+ (define width (+ 4
+ (apply max
+ (map (lambda (x)
+ (length (string x)))
+ (cons 'Function
+ (map car pr))))))
+ (princ (string.rpad "Function" width #\ )
+ "#Calls Time (seconds)")
+ (newline)
+ (princ (string.rpad "--------" width #\ )
+ "------ --------------")
+ (newline)
+ (for-each
+ (lambda (p)
+ (princ (string.rpad (string (caddr p)) width #\ )
+ (string.rpad (string (cadr p)) 11 #\ )
+ (car p))
+ (newline))
+ (simple-sort (map (lambda (l) (reverse (to-proper l)))
+ pr)))))
+ (set! clear-profiles
+ (lambda ()
+ (for-each (lambda (k)
+ (put! *profiles* k (cons 0 0)))
+ (table.keys *profiles*)))))
+
+#;(for-each profile
+ '(emit encode-byte-code const-to-idx-vec
+ index-of lookup-sym in-env? any every
+ compile-sym compile-if compile-begin
+ compile-arglist expand builtin->instruction
+ compile-app separate nconc get-defined-vars
+ compile-in compile compile-f delete-duplicates
+ map length> length= count filter append
+ lastcdr to-proper reverse reverse! list->vector
+ table.foreach list-head list-tail assq memq assoc member
+ assv memv nreconc bq-process))
+
+(define (filt1 pred lst)
+ (define (filt1- pred lst accum)
+ (if (null? lst) accum
+ (if (pred (car lst))
+ (filt1- pred (cdr lst) (cons (car lst) accum))
+ (filt1- pred (cdr lst) accum))))
+ (filt1- pred lst ()))
+
+(define (filto pred lst (accum ()))
+ (if (atom? lst) accum
+ (if (pred (car lst))
+ (filto pred (cdr lst) (cons (car lst) accum))
+ (filto pred (cdr lst) accum))))
+
+; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
+(define (pairwise? pred . args)
+ (or (null? args)
+ (let f ((a (car args)) (d (cdr args)))
+ (or (null? d)
+ (and (pred a (car d)) (f (car d) (cdr d)))))))
--- /dev/null
+++ b/test/tme.lsp
@@ -1,0 +1,4 @@
+(let ((t (table)))
+ (time (dotimes (i 2000000)
+ (put! t (rand) (rand)))))
+#t
--- /dev/null
+++ b/test/torture.scm
@@ -1,0 +1,24 @@
+(define ones (map (lambda (x) 1) (iota 1000000)))
+
+(write (apply + ones))
+(newline)
+
+(define (big n)
+ (if (<= n 0)
+ 0
+ `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
+
+(define nst (big 100000))
+
+(write (eval nst))
+(newline)
+
+(define longg (cons '+ ones))
+(write (eval longg))
+(newline)
+
+(define (f x)
+ (begin (write x)
+ (newline)
+ (f (+ x 1))
+ 0))
--- /dev/null
+++ b/test/torus.lsp
@@ -1,0 +1,48 @@
+; -*- scheme -*-
+(define (maplist f l)
+ (if (null? l) ()
+ (cons (f l) (maplist f (cdr l)))))
+
+; produce a beautiful, toroidal cons structure
+; make m copies of a CDR-circular list of length n, and connect corresponding
+; conses in CAR-circular loops
+; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
+(define (torus m n)
+ (let* ((l (map-int identity n))
+ (g l)
+ (prev g))
+ (dotimes (i (- m 1))
+ (set! prev g)
+ (set! g (maplist identity g))
+ (set-cdr! (last-pair prev) prev))
+ (set-cdr! (last-pair g) g)
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(define (cyl m n)
+ (let* ((l (map-int identity n))
+ (g l))
+ (dotimes (i (- m 1))
+ (set! g (maplist identity g)))
+ (let ((a l)
+ (b g))
+ (dotimes (i n)
+ (set-car! a b)
+ (set! a (cdr a))
+ (set! b (cdr b))))
+ l))
+
+(time (begin (print (torus 100 100)) ()))
+;(time (dotimes (i 1) (load "100x100.lsp")))
+; with ltable
+; printing time: 0.415sec
+; reading time: 0.165sec
+
+; with ptrhash
+; printing time: 0.081sec
+; reading time: 0.0264sec
--- /dev/null
+++ b/test/unittest.lsp
@@ -1,0 +1,307 @@
+; -*- scheme -*-
+(define-macro (assert-fail expr . what)
+ `(assert (trycatch (begin ,expr #f)
+ (lambda (e) ,(if (null? what) #t
+ `(eq? (car e) ',(car what)))))))
+
+(define (every-int n)
+ (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
+ (int64 n) (uint64 n)))
+
+(define (every-sint n)
+ (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
+
+(define (each f l)
+ (if (atom? l) ()
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(define (each^2 f l m)
+ (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
+
+(define (test-lt a b)
+ (each^2 (lambda (neg pos)
+ (begin
+ (eval `(assert (= -1 (compare ,neg ,pos))))
+ (eval `(assert (= 1 (compare ,pos ,neg))))))
+ a
+ b))
+
+(define (test-eq a b)
+ (each^2 (lambda (a b)
+ (begin
+ (eval `(assert (= 0 (compare ,a ,b))))))
+ a
+ b))
+
+(test-lt (every-sint -1) (every-int 1))
+(test-lt (every-int 0) (every-int 1))
+(test-eq (every-int 88) (every-int 88))
+(test-eq (every-sint -88) (every-sint -88))
+
+(define (test-square a)
+ (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
+ a))
+
+(test-square (every-sint -67))
+(test-square (every-int 3))
+(test-square (every-int 0x80000000))
+(test-square (every-sint 0x80000000))
+(test-square (every-sint -0x80000000))
+
+(assert (= (* 128 0x02000001) 0x100000080))
+
+(assert (= (/ 1) 1))
+(assert (= (/ -1) -1))
+(assert (= (/ 2.0) 0.5))
+
+(assert (= (- 4999950000 4999941999) 8001))
+
+(assert (not (eqv? 10 #\newline)))
+(assert (not (eqv? #\newline 10)))
+
+; tricky cases involving INT_MIN
+(assert (< (- #uint32(0x80000000)) 0))
+(assert (> (- #int32(0x80000000)) 0))
+(assert (< (- #uint64(0x8000000000000000)) 0))
+(assert (> (- #int64(0x8000000000000000)) 0))
+; fixnum versions
+(assert (= (- -536870912) 536870912))
+(assert (= (- -2305843009213693952) 2305843009213693952))
+
+(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
+(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+(assert (equal? (* 2 #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+
+(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
+
+(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
+(assert (= (length (string #\x0)) 1))
+
+(assert (> 9223372036854775808 9223372036854775807))
+
+; NaNs
+(assert (equal? +nan.0 +nan.0))
+(assert (not (= +nan.0 +nan.0)))
+(assert (not (= +nan.0 -nan.0)))
+(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
+(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
+(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
+(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
+(assert (not (>= +nan.0 +nan.0)))
+
+; comparing strings
+(assert (< "a" "b"))
+(assert (> "b" "a"))
+(assert (not (< "a" "a")))
+(assert (<= "a" "a"))
+(assert (>= "a" "a"))
+(assert (>= "ab" "aa"))
+
+; -0.0 etc.
+(assert (not (equal? 0.0 0)))
+(assert (equal? 0.0 0.0))
+(assert (not (equal? -0.0 0.0)))
+(assert (not (equal? -0.0 0)))
+(assert (not (eqv? 0.0 0)))
+(assert (not (eqv? -0.0 0)))
+(assert (not (eqv? -0.0 0.0)))
+(assert (= 0.0 -0.0))
+
+; this crashed once
+(for 1 10 (lambda (i) 0))
+
+; failing applications
+(assert-fail ((lambda (x) x) 1 2))
+(assert-fail ((lambda (x) x)))
+(assert-fail ((lambda (x y . z) z) 1))
+(assert-fail (car 'x) type-error)
+(assert-fail gjegherqpfdf___trejif unbound-error)
+
+; long argument lists
+(assert (= (apply + (iota 100000)) 4999950000))
+(define ones (map (lambda (x) 1) (iota 80000)))
+(assert (= (eval `(if (< 2 1)
+ (+ ,@ones)
+ (+ ,@(cdr ones))))
+ 79999))
+
+(define MAX_ARGS 255)
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
+(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
+(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ ,(car (last-pair as)))))
+(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
+(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
+ (lambda () ,(car (last-pair as))))))
+(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
+
+(define as (map-int (lambda (x) (gensym)) 1000))
+(define f (compile `(lambda ,as ,(car (last-pair as)))))
+(assert (equal? (apply f (iota 1000)) 999))
+
+(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
+(define f (compile `(lambda ,as ,(lastcdr as))))
+(assert (equal? (apply f (iota 994)) '()))
+(assert (equal? (apply f (iota 995)) '(994)))
+(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
+
+; optional arguments
+(assert (equal? ((lambda ((b 0)) b)) 0))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
+(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
+
+; keyword arguments
+(assert (keyword? kw:))
+(assert (not (keyword? 'kw)))
+(assert (not (keyword? ':)))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
+ '(1 0 0 (8 4 5))))
+(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
+ '(0 2 3 (1))))
+(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
+(assert (equal? (keys4 a: 10) '(10 3 7 6)))
+(assert (equal? (keys4 b: 10) '(8 10 7 6)))
+(assert (equal? (keys4 c: 10) '(8 3 10 6)))
+(assert (equal? (keys4 d: 10) '(8 3 7 10)))
+(assert-fail (keys4 e: 10)) ; unsupported keyword
+(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
+
+; cvalues and arrays
+(assert (equal? (typeof "") '(array byte)))
+(assert-fail (aref #(1) 3) bounds-error)
+(define iarr (array 'int64 32 16 8 7 1))
+(assert (equal? (aref iarr 0) 32))
+(assert (equal? (aref iarr #int8(3)) 7))
+
+; gensyms
+(assert (gensym? (gensym)))
+(assert (not (gensym? 'a)))
+(assert (not (eq? (gensym) (gensym))))
+(assert (not (equal? (string (gensym)) (string (gensym)))))
+(let ((gs (gensym))) (assert (eq? gs gs)))
+
+; eof object
+(assert (eof-object? (eof-object)))
+(assert (not (eof-object? 1)))
+(assert (not (eof-object? 'a)))
+(assert (not (eof-object? '())))
+(assert (not (eof-object? #f)))
+(assert (not (null? (eof-object))))
+(assert (not (builtin? (eof-object))))
+(assert (not (function? (eof-object))))
+
+; ok, a couple end-to-end tests as well
+(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+(assert (equal? (fib 20) 6765))
+
+(load "color.lsp")
+(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
+ '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))))
+
+; hashing strange things
+(assert (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
+
+(assert (not (equal?
+ (hash '#0=(1 1 #0# . #0#))
+ (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
+
+(assert (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
+
+(assert (not (equal?
+ (hash '#0=((1 . #0#) . #0#))
+ (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
+
+(assert (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 0))))
+
+(assert (not (equal?
+ (hash '(#0=(#0#) 0))
+ (hash '(#1=(((((#1#))))) 1)))))
+
+(assert (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 [2 [#0#]] 3])
+ (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash #0=[1 #0# [2 [#0#]] 3])
+ (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
+
+(assert (equal?
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
+ (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
+
+(assert (not (equal?
+ (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
+ (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
+
+(assert (equal? (hash '#0=(1 . #0#))
+ (hash '#1=(1 1 . #1#))))
+
+(assert (not (equal? (hash '#0=(1 1 . #0#))
+ (hash '#1=(1 #0# . #1#)))))
+
+(assert (not (equal? (hash (iota 10))
+ (hash (iota 20)))))
+
+(assert (not (equal? (hash (iota 41))
+ (hash (iota 42)))))
+
+(if (top-level-bound? 'time.fromstring)
+ (assert (let ((ts (time.string (time.now))))
+ (eqv? ts (time.string (time.fromstring ts))))))
+
+(assert (equal? 0.0 (+ 0.0 0))) ; tests that + no longer does inexact->exact
+
+(assert (equal? 1.0 (* 1.0 1))) ; tests that * no longer does inexact->exact
+
+(define (with-output-to-string nada thunk)
+ (let ((b (buffer)))
+ (with-output-to b (thunk))
+ (io.tostring! b)))
+
+(let ((c #\a))
+ (assert (equal? (with-output-to-string #f (lambda () (print (list c c))))
+ "(#\\a #\\a)")))
+
+(assert-fail (eval '(set! (car (cons 1 2)) 3)))
+
+(princ "all tests pass\n")
+#t
--- /dev/null
+++ b/test/wt.lsp
@@ -1,0 +1,28 @@
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+(define (tw)
+ (set! i 0)
+ (while (< i 10000000) (set! i (+ i 1))))
+
+(define (tw2)
+ (letrec ((loop (lambda ()
+ (if (< i 10000000)
+ (begin (set! i (+ i 1))
+ (loop))
+ ()))))
+ (loop)))
+
+#|
+interpreter:
+while: 1.82sec
+macro: 2.98sec
+
+compiler:
+while: 0.72sec
+macro: 1.24sec
+|#
--- a/tests/100x100.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-'#0=(#198=(#197=(#196=(#195=(#194=(#193=(#192=(#191=(#190=(#189=(#188=(#187=(#186=(#185=(#184=(#183=(#182=(#181=(#180=(#179=(#178=(#177=(#176=(#175=(#174=(#173=(#172=(#171=(#170=(#169=(#168=(#167=(#166=(#165=(#164=(#163=(#162=(#161=(#160=(#159=(#158=(#157=(#156=(#155=(#154=(#153=(#152=(#151=(#150=(#149=(#148=(#147=(#146=(#145=(#144=(#143=(#142=(#141=(#140=(#139=(#138=(#137=(#136=(#135=(#134=(#133=(#132=(#131=(#130=(#129=(#128=(#127=(#126=(#125=(#124=(#123=(#122=(#121=(#120=(#119=(#118=(#117=(#116=(#115=(#114=(#113=(#112=(#111=(#110=(#109=(#108=(#107=(#106=(#105=(#104=(#103=(#102=(#101=(#100=(#0# . #1=(#9999=(#9998=(#9997=(#9996=(#9995=(#9994=(#9993=(#9992=(#9991=(#9990=(#9989=(#9988=(#9987=(#9986=(#9985=(#9984=(#9983=(#9982=(#9981=(#9980=(#9979=(#9978=(#9977=(#9976=(#9975=(#9974=(#9973=(#9972=(#9971=(#9970=(#9969=(#9968=(#9967=(#9966=(#9965=(#9964=(#9963=(#9962=(#9961=(#9960=(#9959=(#9958=(#9957=(#9956=(#9955=(#9954=(#9953=(#9952=(#9951=(#9950=(#9949=(#9948=(#9947=(#9946=(#9945=(#9944=(#9943=(#9942=(#9941=(#9940=(#9939=(#9938=(#9937=(#9936=(#9935=(#9934=(#9933=(#9932=(#9931=(#9930=(#9929=(#9928=(#9927=(#9926=(#9925=(#9924=(#9923=(#9922=(#9921=(#9920=(#9919=(#9918=(#9917=(#9916=(#9915=(#9914=(#9913=(#9912=(#9911=(#9910=(#9909=(#9908=(#9907=(#9906=(#9905=(#9904=(#9903=(#9902=(#9901=(#1# . #2=(#9900=(#9899=(#9898=(#9897=(#9896=(#9895=(#9894=(#9893=(#9892=(#9891=(#9890=(#9889=(#9888=(#9887=(#9886=(#9885=(#9884=(#9883=(#9882=(#9881=(#9880=(#9879=(#9878=(#9877=(#9876=(#9875=(#9874=(#9873=(#9872=(#9871=(#9870=(#9869=(#9868=(#9867=(#9866=(#9865=(#9864=(#9863=(#9862=(#9861=(#9860=(#9859=(#9858=(#9857=(#9856=(#9855=(#9854=(#9853=(#9852=(#9851=(#9850=(#9849=(#9848=(#9847=(#9846=(#9845=(#9844=(#9843=(#9842=(#9841=(#9840=(#9839=(#9838=(#9837=(#9836=(#9835=(#9834=(#9833=(#9832=(#9831=(#9830=(#9829=(#9828=(#9827=(#9826=(#9825=(#9824=(#9823=(#9822=(#9821=(#9820=(#9819=(#9818=(#9817=(#9816=(#9815=(#9814=(#9813=(#9812=(#9811=(#9810=(#9809=(#9808=(#9807=(#9806=(#9805=(#9804=(#9803=(#9802=(#2# . #3=(#9801=(#9800=(#9799=(#9798=(#9797=(#9796=(#9795=(#9794=(#9793=(#9792=(#9791=(#9790=(#9789=(#9788=(#9787=(#9786=(#9785=(#9784=(#9783=(#9782=(#9781=(#9780=(#9779=(#9778=(#9777=(#9776=(#9775=(#9774=(#9773=(#9772=(#9771=(#9770=(#9769=(#9768=(#9767=(#9766=(#9765=(#9764=(#9763=(#9762=(#9761=(#9760=(#9759=(#9758=(#9757=(#9756=(#9755=(#9754=(#9753=(#9752=(#9751=(#9750=(#9749=(#9748=(#9747=(#9746=(#9745=(#9744=(#9743=(#9742=(#9741=(#9740=(#9739=(#9738=(#9737=(#9736=(#9735=(#9734=(#9733=(#9732=(#9731=(#9730=(#9729=(#9728=(#9727=(#9726=(#9725=(#9724=(#9723=(#9722=(#9721=(#9720=(#9719=(#9718=(#9717=(#9716=(#9715=(#9714=(#9713=(#9712=(#9711=(#9710=(#9709=(#9708=(#9707=(#9706=(#9705=(#9704=(#9703=(#3# . #4=(#9702=(#9701=(#9700=(#9699=(#9698=(#9697=(#9696=(#9695=(#9694=(#9693=(#9692=(#9691=(#9690=(#9689=(#9688=(#9687=(#9686=(#9685=(#9684=(#9683=(#9682=(#9681=(#9680=(#9679=(#9678=(#9677=(#9676=(#9675=(#9674=(#9673=(#9672=(#9671=(#9670=(#9669=(#9668=(#9667=(#9666=(#9665=(#9664=(#9663=(#9662=(#9661=(#9660=(#9659=(#9658=(#9657=(#9656=(#9655=(#9654=(#9653=(#9652=(#9651=(#9650=(#9649=(#9648=(#9647=(#9646=(#9645=(#9644=(#9643=(#9642=(#9641=(#9640=(#9639=(#9638=(#9637=(#9636=(#9635=(#9634=(#9633=(#9632=(#9631=(#9630=(#9629=(#9628=(#9627=(#9626=(#9625=(#9624=(#9623=(#9622=(#9621=(#9620=(#9619=(#9618=(#9617=(#9616=(#9615=(#9614=(#9613=(#9612=(#9611=(#9610=(#9609=(#9608=(#9607=(#9606=(#9605=(#9604=(#4# . #5=(#9603=(#9602=(#9601=(#9600=(#9599=(#9598=(#9597=(#9596=(#9595=(#9594=(#9593=(#9592=(#9591=(#9590=(#9589=(#9588=(#9587=(#9586=(#9585=(#9584=(#9583=(#9582=(#9581=(#9580=(#9579=(#9578=(#9577=(#9576=(#9575=(#9574=(#9573=(#9572=(#9571=(#9570=(#9569=(#9568=(#9567=(#9566=(#9565=(#9564=(#9563=(#9562=(#9561=(#9560=(#9559=(#9558=(#9557=(#9556=(#9555=(#9554=(#9553=(#9552=(#9551=(#9550=(#9549=(#9548=(#9547=(#9546=(#9545=(#9544=(#9543=(#9542=(#9541=(#9540=(#9539=(#9538=(#9537=(#9536=(#9535=(#9534=(#9533=(#9532=(#9531=(#9530=(#9529=(#9528=(#9527=(#9526=(#9525=(#9524=(#9523=(#9522=(#9521=(#9520=(#9519=(#9518=(#9517=(#9516=(#9515=(#9514=(#9513=(#9512=(#9511=(#9510=(#9509=(#9508=(#9
\ No newline at end of file
--- a/tests/argv.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-(print *argv*) (princ "\n")
--- a/tests/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/tests/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/tests/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/tests/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/tests/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/tests/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)))))))
--- a/tests/color.lsp
+++ /dev/null
@@ -1,89 +1,0 @@
-; -*- scheme -*-
-
-; dictionaries ----------------------------------------------------------------
-(define (dict-new) ())
-
-(define (dict-extend dl key value)
- (cond ((null? dl) (list (cons key value)))
- ((equal? key (caar dl)) (cons (cons key value) (cdr dl)))
- (else (cons (car dl) (dict-extend (cdr dl) key value)))))
-
-(define (dict-lookup dl key)
- (cond ((null? dl) ())
- ((equal? key (caar dl)) (cdar dl))
- (else (dict-lookup (cdr dl) key))))
-
-(define (dict-keys dl) (map car dl))
-
-; graphs ----------------------------------------------------------------------
-(define (graph-empty) (dict-new))
-
-(define (graph-connect g n1 n2)
- (dict-extend
- (dict-extend g n2 (cons n1 (dict-lookup g n2)))
- n1
- (cons n2 (dict-lookup g n1))))
-
-(define (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
-
-(define (graph-neighbors g n) (dict-lookup g n))
-
-(define (graph-nodes g) (dict-keys g))
-
-(define (graph-add-node g n1) (dict-extend g n1 ()))
-
-(define (graph-from-edges edge-list)
- (if (null? edge-list)
- (graph-empty)
- (graph-connect (graph-from-edges (cdr edge-list))
- (caar edge-list)
- (cdar edge-list))))
-
-; graph coloring --------------------------------------------------------------
-(define (node-colorable? g coloring node-to-color color-of-node)
- (not (member
- color-of-node
- (map
- (lambda (n)
- (let ((color-pair (assq n coloring)))
- (if (pair? color-pair) (cdr color-pair) ())))
- (graph-neighbors g node-to-color)))))
-
-(define (try-each f lst)
- (if (null? lst) #f
- (let ((ret (f (car lst))))
- (if ret ret (try-each f (cdr lst))))))
-
-(define (color-node g coloring colors uncolored-nodes color)
- (cond
- ((null? uncolored-nodes) coloring)
- ((node-colorable? g coloring (car uncolored-nodes) color)
- (let ((new-coloring
- (cons (cons (car uncolored-nodes) color) coloring)))
- (try-each (lambda (c)
- (color-node g new-coloring colors (cdr uncolored-nodes) c))
- colors)))))
-
-(define (color-graph g colors)
- (if (null? colors)
- (and (null? (graph-nodes g)) ())
- (color-node g () colors (graph-nodes g) (car colors))))
-
-(define (color-pairs pairs colors)
- (color-graph (graph-from-edges pairs) colors))
-
-; queens ----------------------------------------------------------------------
-(define (can-attack x y)
- (let ((x1 (mod x 5))
- (y1 (truncate (/ x 5)))
- (x2 (mod y 5))
- (y2 (truncate (/ y 5))))
- (or (= x1 x2) (= y1 y2) (= (abs (- y2 y1)) (abs (- x2 x1))))))
-
-(define (generate-5x5-pairs)
- (let ((result ()))
- (dotimes (x 25)
- (dotimes (y 25)
- (if (and (not (= x y)) (can-attack x y))
- (set! result (cons (cons x y) result)) ())))
- result))
--- a/tests/equal.scm
+++ /dev/null
@@ -1,68 +1,0 @@
-; Terminating equal predicate
-; by Jeff Bezanson
-;
-; This version only considers pairs and simple atoms.
-
-; equal?, with bounded recursion. returns 0 if we suspect
-; nontermination, otherwise #t or #f for the correct answer.
-(define (bounded-equal a b N)
- (cond ((<= N 0) 0)
- ((and (pair? a) (pair? b))
- (let ((as
- (bounded-equal (car a) (car b) (- N 1))))
- (if (number? as)
- 0
- (and as
- (bounded-equal (cdr a) (cdr b) (- N 1))))))
- (else (eq? a b))))
-
-; union-find algorithm
-
-; find equivalence class of a cons cell, or #f if not yet known
-; the root of a class is a cons that is its own class
-(define (class table key)
- (let ((c (hashtable-ref table key #f)))
- (if (or (not c) (eq? c key))
- c
- (class table c))))
-
-; move a and b to the same equivalence class, given c and cb
-; as the current values of (class table a) and (class table b)
-; Note: this is not quite optimal. We blindly pick 'a' as the
-; root of the new class, but we should pick whichever class is
-; larger.
-(define (union! table a b c cb)
- (let ((ca (if c c a)))
- (if cb
- (hashtable-set! table cb ca))
- (hashtable-set! table a ca)
- (hashtable-set! table b ca)))
-
-; cyclic equal. first, attempt to compare a and b as best
-; we can without recurring. if we can't prove them different,
-; set them equal and move on.
-(define (cyc-equal a b table)
- (cond ((eq? a b) #t)
- ((not (and (pair? a) (pair? b))) (eq? a b))
- (else
- (let ((aa (car a)) (da (cdr a))
- (ab (car b)) (db (cdr b)))
- (cond ((or (not (eq? (atom? aa) (atom? ab)))
- (not (eq? (atom? da) (atom? db)))) #f)
- ((and (atom? aa)
- (not (eq? aa ab))) #f)
- ((and (atom? da)
- (not (eq? da db))) #f)
- (else
- (let ((ca (class table a))
- (cb (class table b)))
- (if (and ca cb (eq? ca cb))
- #t
- (begin (union! table a b ca cb)
- (and (cyc-equal aa ab table)
- (cyc-equal da db table)))))))))))
-
-(define (equal a b)
- (let ((guess (bounded-equal a b 2048)))
- (if (boolean? guess) guess
- (cyc-equal a b (make-eq-hashtable)))))
--- a/tests/err.lsp
+++ /dev/null
@@ -1,4 +1,0 @@
-(define (f x) (begin (list-tail '(1) 3) 3))
-(f 2)
-a
-(trycatch a (lambda (e) (print (stacktrace))))
--- a/tests/hashtest.lsp
+++ /dev/null
@@ -1,40 +1,0 @@
-; -*- scheme -*-
-
-(define (hins1)
- (let ((h (table)))
- (dotimes (n 200000)
- (put! h (mod (rand) 1000) 'apple))
- h))
-
-(define (hread h)
- (dotimes (n 200000)
- (get h (mod (rand) 10000) nil)))
-
-(time (dotimes (i 100000)
- (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9)))
-(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8)))
-(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4)))
-(time (dotimes (i 100000) (table :a 1 :b 2)))
-(time (dotimes (i 100000) (table)))
-
-#t
-
-#|
-
-with HT_N_INLINE==16
-Elapsed time: 0.0796329975128174 seconds
-Elapsed time: 0.0455679893493652 seconds
-Elapsed time: 0.0272290706634521 seconds
-Elapsed time: 0.0177979469299316 seconds
-Elapsed time: 0.0102229118347168 seconds
-
-
-with HT_N_INLINE==8
-
-Elapsed time: 0.1010119915008545 seconds
-Elapsed time: 0.174872875213623 seconds
-Elapsed time: 0.0322129726409912 seconds
-Elapsed time: 0.0195930004119873 seconds
-Elapsed time: 0.008836030960083 seconds
-
-|#
--- a/tests/perf.lsp
+++ /dev/null
@@ -1,37 +1,0 @@
-(load "test.lsp")
-
-(princ "colorgraph: ")
-(load "tcolor.lsp")
-
-(princ "fib(34): ")
-(assert (equal? (time (fib 34)) 5702887))
-(princ "yfib(32): ")
-(assert (equal? (time (yfib 32)) 2178309))
-
-(princ "sort: ")
-(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
-(time (simple-sort r))
-
-(princ "expand: ")
-(time (dotimes (n 5000) (expand '(dotimes (i 100) body1 body2))))
-
-(define (my-append . lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (else (letrec ((append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d))))))
- (append2 (car lsts) (apply my-append (cdr lsts)))))))
-
-(princ "append: ")
-(set! L (map-int (lambda (x) (map-int identity 20)) 20))
-(time (dotimes (n 1000) (apply my-append L)))
-
-(path.cwd "ast")
-(princ "p-lambda: ")
-(load "rpasses.lsp")
-(define *input* (load "datetimeR.lsp"))
-(time (set! *output* (compile-ish *input*)))
-(assert (equal? *output* (load "rpasses-out.lsp")))
-(path.cwd "..")
--- a/tests/pisum.lsp
+++ /dev/null
@@ -1,8 +1,0 @@
-(define (pisum)
- (dotimes (j 500)
- ((label sumloop
- (lambda (i sum)
- (if (> i 10000)
- sum
- (sumloop (+ i 1) (+ sum (/ (* i i)))))))
- 1.0 0.0)))
--- a/tests/printcases.lsp
+++ /dev/null
@@ -1,26 +1,0 @@
-expand
-append
-bq-process
-
-(define (syntax-environment)
- (map (lambda (s) (cons s (symbol-syntax s)))
- (filter symbol-syntax (environment))))
-
-(syntax-environment)
-
-(symbol-syntax 'try)
-
-(map-int (lambda (x) `(a b c d e)) 90)
-
-(list->vector (map-int (lambda (x) `(a b c d e)) 90))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
-
-'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))
--- a/tests/tcolor.lsp
+++ /dev/null
@@ -1,16 +1,0 @@
-; -*- scheme -*-
-; color for performance
-
-(load "color.lsp")
-
-; 100x color 5 queens
-(define Q (generate-5x5-pairs))
-(define (ct)
- (set! C (color-pairs Q '(a b c d e)))
- (dotimes (n 99) (color-pairs Q '(a b c d e))))
-(time (ct))
-(assert (equal? C
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
--- a/tests/test.lsp
+++ /dev/null
@@ -1,294 +1,0 @@
-; -*- scheme -*-
-
-; make label self-evaluating, but evaluating the lambda in the process
-;(defmacro labl (name f)
-; (list list ''labl (list 'quote name) f))
-
-(define-macro (labl name f)
- `(let (,name) (set! ,name ,f)))
-
-;(define (reverse lst)
-; ((label rev-help (lambda (lst result)
-; (if (null? lst) result
-; (rev-help (cdr lst) (cons (car lst) result)))))
-; lst ()))
-
-(define (append- . lsts)
- ((label append-h
- (lambda (lsts)
- (cond ((null? lsts) ())
- ((null? (cdr lsts)) (car lsts))
- (#t ((label append2 (lambda (l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d)))))
- (car lsts) (append-h (cdr lsts)))))))
- lsts))
-
-;(princ 'Hello '| | 'world! "\n")
-;(filter (lambda (x) (not (< x 0))) '(1 -1 -2 5 10 -8 0))
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-;(princ (time (fib 34)) "\n")
-;(dotimes (i 20000) (map-int (lambda (x) (list 'quote x)) 8))
-;(dotimes (i 40000) (append '(a b) '(1 2 3 4) () '(c) () '(5 6)))
-;(dotimes (i 80000) (list 1 2 3 4 5))
-;(set! a (map-int identity 10000))
-;(dotimes (i 200) (rfoldl cons () a))
-
-#|
-(define-macro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(let ((,v 0))
- (while (< ,v ,cnt)
- (prog1
- ,(cons 'begin body)
- (set! ,v (+ ,v 1)))))))
-
-(define (map-int f n)
- (if (<= n 0)
- ()
- (let ((first (cons (f 0) ())))
- ((label map-int-
- (lambda (acc i n)
- (if (= i n)
- first
- (begin (set-cdr! acc (cons (f i) ()))
- (map-int- (cdr acc) (+ i 1) n)))))
- first 1 n))))
-|#
-
-(define-macro (labl name fn)
- `((lambda (,name) (set! ,name ,fn)) ()))
-
-(define (square x) (* x x))
-(define (expt b p)
- (cond ((= p 0) 1)
- ((= b 0) 0)
- ((even? p) (square (expt b (div0 p 2))))
- (#t (* b (expt b (- p 1))))))
-
-(define (gcd a b)
- (cond ((= a 0) b)
- ((= b 0) a)
- ((< a b) (gcd a (- b a)))
- (#t (gcd b (- a b)))))
-
-; like eval-when-compile
-(define-macro (literal expr)
- (let ((v (eval expr)))
- (if (self-evaluating? v) v (list quote v))))
-
-(define (cardepth l)
- (if (atom? l) 0
- (+ 1 (cardepth (car l)))))
-
-(define (nestlist f zero n)
- (if (<= n 0) ()
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(define (mapl f . lsts)
- ((label mapl-
- (lambda (lsts)
- (if (null? (car lsts)) ()
- (begin (apply f lsts) (mapl- (map cdr lsts))))))
- lsts))
-
-; test to see if a symbol begins with :
-(define (keywordp s)
- (and (>= s '|:|) (<= s '|:~|)))
-
-; swap the cars and cdrs of every cons in a structure
-(define (swapad c)
- (if (atom? c) c
- (set-cdr! c (K (swapad (car c))
- (set-car! c (swapad (cdr c)))))))
-
-(define (without x l)
- (filter (lambda (e) (not (eq e x))) l))
-
-(define (conscount c)
- (if (pair? c) (+ 1
- (conscount (car c))
- (conscount (cdr c)))
- 0))
-
-; _ Welcome to
-; (_ _ _ |_ _ | . _ _ 2
-; | (-||||_(_)|__|_)|_)
-; ==================|==
-
-;[` _ ,_ |- | . _ 2
-;| (/_||||_()|_|_\|)
-; |
-
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-; this would be a cool use of thunking to handle 'finally' clauses, but
-; this code doesn't work in the case where the user manually re-raises
-; inside a catch block. one way to handle it would be to replace all
-; their uses of 'raise' with '*_try_finally_raise_*' which calls the thunk.
-; (try expr
-; (catch (TypeError e) . exprs)
-; (catch (IOError e) . exprs)
-; (finally . exprs))
-(define-macro (try expr . forms)
- (let ((final (f-body (cdr (or (assq 'finally forms) '(())))))
- (body (foldr
- ; create a function to check for and handle one exception
- ; type, and pass off control to the next when no match
- (lambda (catc next)
- (let ((var (cadr (cadr catc)))
- (extype (caadr catc))
- (todo (f-body (cddr catc))))
- `(lambda (,var)
- (if (or (eq ,var ',extype)
- (and (pair? ,var)
- (eq (car ,var) ',extype)))
- ,todo
- (,next ,var)))))
-
- ; default function; no matches so re-raise
- '(lambda (e) (begin (*_try_finally_thunk_*) (raise e)))
-
- ; make list of catch forms
- (filter (lambda (f) (eq (car f) 'catch)) forms))))
- `(let ((*_try_finally_thunk_* (lambda () ,final)))
- (prog1 (attempt ,expr ,body)
- (*_try_finally_thunk_*)))))
-
-(define Y
- (lambda (f)
- ((lambda (h)
- (f (lambda (x) ((h h) x))))
- (lambda (h)
- (f (lambda (x) ((h h) x)))))))
-
-(define yfib
- (Y (lambda (fib)
- (lambda (n)
- (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
-
-;(defun tt () (time (dotimes (i 500000) (* 0x1fffffff 1) )))
-;(tt)
-;(tt)
-;(tt)
-
-(define-macro (accumulate-while cnd what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (while ,cnd
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body)))))))
-
-(define-macro (accumulate-for var lo hi what . body)
- (let ((acc (gensym)))
- `(let ((,acc (list ())))
- (cdr
- (prog1 ,acc
- (for ,lo ,hi
- (lambda (,var)
- (begin (set! ,acc
- (cdr (set-cdr! ,acc (cons ,what ()))))
- ,@body))))))))
-
-(define (map-indexed f lst)
- (if (atom? lst) lst
- (let ((i 0))
- (accumulate-while (pair? lst) (f (car lst) i)
- (begin (set! lst (cdr lst))
- (set! i (1+ i)))))))
-
-(define (string.findall haystack needle . offs)
- (define (sub h n offs lst)
- (let ((i (string.find h n offs)))
- (if i
- (sub h n (string.inc h i) (cons i lst))
- (reverse! lst))))
- (sub haystack needle (if (null? offs) 0 (car offs)) ()))
-
-(let ((*profiles* (table)))
- (set! profile
- (lambda (s)
- (let ((f (top-level-value s)))
- (put! *profiles* s (cons 0 0))
- (set-top-level-value! s
- (lambda args
- (define tt (get *profiles* s))
- (define count (car tt))
- (define time (cdr tt))
- (define t0 (time.now))
- (define v (apply f args))
- (set-cdr! tt (+ time (- (time.now) t0)))
- (set-car! tt (+ count 1))
- v)))))
- (set! show-profiles
- (lambda ()
- (define pr (filter (lambda (x) (> (cadr x) 0))
- (table.pairs *profiles*)))
- (define width (+ 4
- (apply max
- (map (lambda (x)
- (length (string x)))
- (cons 'Function
- (map car pr))))))
- (princ (string.rpad "Function" width #\ )
- "#Calls Time (seconds)")
- (newline)
- (princ (string.rpad "--------" width #\ )
- "------ --------------")
- (newline)
- (for-each
- (lambda (p)
- (princ (string.rpad (string (caddr p)) width #\ )
- (string.rpad (string (cadr p)) 11 #\ )
- (car p))
- (newline))
- (simple-sort (map (lambda (l) (reverse (to-proper l)))
- pr)))))
- (set! clear-profiles
- (lambda ()
- (for-each (lambda (k)
- (put! *profiles* k (cons 0 0)))
- (table.keys *profiles*)))))
-
-#;(for-each profile
- '(emit encode-byte-code const-to-idx-vec
- index-of lookup-sym in-env? any every
- compile-sym compile-if compile-begin
- compile-arglist expand builtin->instruction
- compile-app separate nconc get-defined-vars
- compile-in compile compile-f delete-duplicates
- map length> length= count filter append
- lastcdr to-proper reverse reverse! list->vector
- table.foreach list-head list-tail assq memq assoc member
- assv memv nreconc bq-process))
-
-(define (filt1 pred lst)
- (define (filt1- pred lst accum)
- (if (null? lst) accum
- (if (pred (car lst))
- (filt1- pred (cdr lst) (cons (car lst) accum))
- (filt1- pred (cdr lst) accum))))
- (filt1- pred lst ()))
-
-(define (filto pred lst (accum ()))
- (if (atom? lst) accum
- (if (pred (car lst))
- (filto pred (cdr lst) (cons (car lst) accum))
- (filto pred (cdr lst) accum))))
-
-; (pairwise? p a b c d) == (and (p a b) (p b c) (p c d))
-(define (pairwise? pred . args)
- (or (null? args)
- (let f ((a (car args)) (d (cdr args)))
- (or (null? d)
- (and (pred a (car d)) (f (car d) (cdr d)))))))
--- a/tests/tme.lsp
+++ /dev/null
@@ -1,4 +1,0 @@
-(let ((t (table)))
- (time (dotimes (i 2000000)
- (put! t (rand) (rand)))))
-#t
--- a/tests/torture.scm
+++ /dev/null
@@ -1,24 +1,0 @@
-(define ones (map (lambda (x) 1) (iota 1000000)))
-
-(write (apply + ones))
-(newline)
-
-(define (big n)
- (if (<= n 0)
- 0
- `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-
-(define nst (big 100000))
-
-(write (eval nst))
-(newline)
-
-(define longg (cons '+ ones))
-(write (eval longg))
-(newline)
-
-(define (f x)
- (begin (write x)
- (newline)
- (f (+ x 1))
- 0))
--- a/tests/torus.lsp
+++ /dev/null
@@ -1,48 +1,0 @@
-; -*- scheme -*-
-(define (maplist f l)
- (if (null? l) ()
- (cons (f l) (maplist f (cdr l)))))
-
-; produce a beautiful, toroidal cons structure
-; make m copies of a CDR-circular list of length n, and connect corresponding
-; conses in CAR-circular loops
-; replace maplist 'identity' with 'copy-tree' for rapdily exploding memory use
-(define (torus m n)
- (let* ((l (map-int identity n))
- (g l)
- (prev g))
- (dotimes (i (- m 1))
- (set! prev g)
- (set! g (maplist identity g))
- (set-cdr! (last-pair prev) prev))
- (set-cdr! (last-pair g) g)
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(define (cyl m n)
- (let* ((l (map-int identity n))
- (g l))
- (dotimes (i (- m 1))
- (set! g (maplist identity g)))
- (let ((a l)
- (b g))
- (dotimes (i n)
- (set-car! a b)
- (set! a (cdr a))
- (set! b (cdr b))))
- l))
-
-(time (begin (print (torus 100 100)) ()))
-;(time (dotimes (i 1) (load "100x100.lsp")))
-; with ltable
-; printing time: 0.415sec
-; reading time: 0.165sec
-
-; with ptrhash
-; printing time: 0.081sec
-; reading time: 0.0264sec
--- a/tests/unittest.lsp
+++ /dev/null
@@ -1,307 +1,0 @@
-; -*- scheme -*-
-(define-macro (assert-fail expr . what)
- `(assert (trycatch (begin ,expr #f)
- (lambda (e) ,(if (null? what) #t
- `(eq? (car e) ',(car what)))))))
-
-(define (every-int n)
- (list (fixnum n) (int8 n) (uint8 n) (int16 n) (uint16 n) (int32 n) (uint32 n)
- (int64 n) (uint64 n)))
-
-(define (every-sint n)
- (list (fixnum n) (int8 n) (int16 n) (int32 n) (int64 n)))
-
-(define (each f l)
- (if (atom? l) ()
- (begin (f (car l))
- (each f (cdr l)))))
-
-(define (each^2 f l m)
- (each (lambda (o) (each (lambda (p) (f o p)) m)) l))
-
-(define (test-lt a b)
- (each^2 (lambda (neg pos)
- (begin
- (eval `(assert (= -1 (compare ,neg ,pos))))
- (eval `(assert (= 1 (compare ,pos ,neg))))))
- a
- b))
-
-(define (test-eq a b)
- (each^2 (lambda (a b)
- (begin
- (eval `(assert (= 0 (compare ,a ,b))))))
- a
- b))
-
-(test-lt (every-sint -1) (every-int 1))
-(test-lt (every-int 0) (every-int 1))
-(test-eq (every-int 88) (every-int 88))
-(test-eq (every-sint -88) (every-sint -88))
-
-(define (test-square a)
- (each (lambda (i) (eval `(assert (>= (* ,i ,i) 0))))
- a))
-
-(test-square (every-sint -67))
-(test-square (every-int 3))
-(test-square (every-int 0x80000000))
-(test-square (every-sint 0x80000000))
-(test-square (every-sint -0x80000000))
-
-(assert (= (* 128 0x02000001) 0x100000080))
-
-(assert (= (/ 1) 1))
-(assert (= (/ -1) -1))
-(assert (= (/ 2.0) 0.5))
-
-(assert (= (- 4999950000 4999941999) 8001))
-
-(assert (not (eqv? 10 #\newline)))
-(assert (not (eqv? #\newline 10)))
-
-; tricky cases involving INT_MIN
-(assert (< (- #uint32(0x80000000)) 0))
-(assert (> (- #int32(0x80000000)) 0))
-(assert (< (- #uint64(0x8000000000000000)) 0))
-(assert (> (- #int64(0x8000000000000000)) 0))
-; fixnum versions
-(assert (= (- -536870912) 536870912))
-(assert (= (- -2305843009213693952) 2305843009213693952))
-
-(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
-(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-(assert (equal? (* 2 #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-
-(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
-
-(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
-(assert (= (length (string #\x0)) 1))
-
-(assert (> 9223372036854775808 9223372036854775807))
-
-; NaNs
-(assert (equal? +nan.0 +nan.0))
-(assert (not (= +nan.0 +nan.0)))
-(assert (not (= +nan.0 -nan.0)))
-(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
-(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
-(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
-(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
-(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
-(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
-(assert (not (>= +nan.0 +nan.0)))
-
-; comparing strings
-(assert (< "a" "b"))
-(assert (> "b" "a"))
-(assert (not (< "a" "a")))
-(assert (<= "a" "a"))
-(assert (>= "a" "a"))
-(assert (>= "ab" "aa"))
-
-; -0.0 etc.
-(assert (not (equal? 0.0 0)))
-(assert (equal? 0.0 0.0))
-(assert (not (equal? -0.0 0.0)))
-(assert (not (equal? -0.0 0)))
-(assert (not (eqv? 0.0 0)))
-(assert (not (eqv? -0.0 0)))
-(assert (not (eqv? -0.0 0.0)))
-(assert (= 0.0 -0.0))
-
-; this crashed once
-(for 1 10 (lambda (i) 0))
-
-; failing applications
-(assert-fail ((lambda (x) x) 1 2))
-(assert-fail ((lambda (x) x)))
-(assert-fail ((lambda (x y . z) z) 1))
-(assert-fail (car 'x) type-error)
-(assert-fail gjegherqpfdf___trejif unbound-error)
-
-; long argument lists
-(assert (= (apply + (iota 100000)) 4999950000))
-(define ones (map (lambda (x) 1) (iota 80000)))
-(assert (= (eval `(if (< 2 1)
- (+ ,@ones)
- (+ ,@(cdr ones))))
- 79999))
-
-(define MAX_ARGS 255)
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 1))))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota (+ MAX_ARGS 0))) `()))
-(assert (equal? (apply f (iota (+ MAX_ARGS 1))) `(,MAX_ARGS)))
-(assert (equal? (apply f (iota (+ MAX_ARGS 2))) `(,MAX_ARGS ,(+ MAX_ARGS 1))))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) (+ MAX_ARGS 100))))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- ,(car (last-pair as)))))
-(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
-(define ff (compile `(lambda ,as (set! ,(car (last-pair as)) 42)
- (lambda () ,(car (last-pair as))))))
-(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
-
-(define as (map-int (lambda (x) (gensym)) 1000))
-(define f (compile `(lambda ,as ,(car (last-pair as)))))
-(assert (equal? (apply f (iota 1000)) 999))
-
-(define as (apply list* (map-int (lambda (x) (gensym)) 995)))
-(define f (compile `(lambda ,as ,(lastcdr as))))
-(assert (equal? (apply f (iota 994)) '()))
-(assert (equal? (apply f (iota 995)) '(994)))
-(assert (equal? (apply f (iota 1000)) '(994 995 996 997 998 999)))
-
-; optional arguments
-(assert (equal? ((lambda ((b 0)) b)) 0))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1) '(1 2)))
-(assert (equal? ((lambda (a (b 2)) (list a b)) 1 3) '(1 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
-(assert (equal? ((lambda (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
-(assert (equal? ((lambda ((x 0) . r) (list x r))) '(0 ())))
-(assert (equal? ((lambda ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
-
-; keyword arguments
-(assert (keyword? kw:))
-(assert (not (keyword? 'kw)))
-(assert (not (keyword? ':)))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 1 0 8 4 5)
- '(1 0 0 (8 4 5))))
-(assert (equal? ((lambda (x (a 2) (b: a) . r) (list x a b r)) 0 b: 3 1)
- '(0 2 3 (1))))
-(define (keys4 (a: 8) (b: 3) (c: 7) (d: 6)) (list a b c d))
-(assert (equal? (keys4 a: 10) '(10 3 7 6)))
-(assert (equal? (keys4 b: 10) '(8 10 7 6)))
-(assert (equal? (keys4 c: 10) '(8 3 10 6)))
-(assert (equal? (keys4 d: 10) '(8 3 7 10)))
-(assert-fail (keys4 e: 10)) ; unsupported keyword
-(assert-fail (keys4 a: 1 b:)) ; keyword with no argument
-
-; cvalues and arrays
-(assert (equal? (typeof "") '(array byte)))
-(assert-fail (aref #(1) 3) bounds-error)
-(define iarr (array 'int64 32 16 8 7 1))
-(assert (equal? (aref iarr 0) 32))
-(assert (equal? (aref iarr #int8(3)) 7))
-
-; gensyms
-(assert (gensym? (gensym)))
-(assert (not (gensym? 'a)))
-(assert (not (eq? (gensym) (gensym))))
-(assert (not (equal? (string (gensym)) (string (gensym)))))
-(let ((gs (gensym))) (assert (eq? gs gs)))
-
-; eof object
-(assert (eof-object? (eof-object)))
-(assert (not (eof-object? 1)))
-(assert (not (eof-object? 'a)))
-(assert (not (eof-object? '())))
-(assert (not (eof-object? #f)))
-(assert (not (null? (eof-object))))
-(assert (not (builtin? (eof-object))))
-(assert (not (function? (eof-object))))
-
-; ok, a couple end-to-end tests as well
-(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-(assert (equal? (fib 20) 6765))
-
-(load "color.lsp")
-(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
- '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))))
-
-; hashing strange things
-(assert (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 1 #1# 1 1 #1# . #1#))))
-
-(assert (not (equal?
- (hash '#0=(1 1 #0# . #0#))
- (hash '#1=(1 2 #1# 1 1 #1# . #1#)))))
-
-(assert (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (1 . #1#) . #1#))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((2 . #1#) (1 . #1#) . #1#)))))
-
-(assert (not (equal?
- (hash '#0=((1 . #0#) . #0#))
- (hash '#1=((1 . #1#) (2 . #1#) . #1#)))))
-
-(assert (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 0))))
-
-(assert (not (equal?
- (hash '(#0=(#0#) 0))
- (hash '(#1=(((((#1#))))) 1)))))
-
-(assert (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[1 [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 [2 [#0#]] 3])
- (hash #1=[1 [2 [[5 [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[1 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3])))
-
-(assert (not (equal?
- (hash #0=[1 #0# [2 [#0#]] 3])
- (hash #1=[6 #1# [2 [[1 #1# [2 [#1#]] 3]]] 3]))))
-
-(assert (equal?
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])
- (hash [1 [2 [[1 1 [2 [1]] 3]]] 3])))
-
-(assert (not (equal?
- (hash [6 1 [2 [[3 1 [2 [1]] 3]]] 3])
- (hash [6 1 [2 [[1 1 [2 [1]] 3]]] 3]))))
-
-(assert (equal? (hash '#0=(1 . #0#))
- (hash '#1=(1 1 . #1#))))
-
-(assert (not (equal? (hash '#0=(1 1 . #0#))
- (hash '#1=(1 #0# . #1#)))))
-
-(assert (not (equal? (hash (iota 10))
- (hash (iota 20)))))
-
-(assert (not (equal? (hash (iota 41))
- (hash (iota 42)))))
-
-(if (top-level-bound? 'time.fromstring)
- (assert (let ((ts (time.string (time.now))))
- (eqv? ts (time.string (time.fromstring ts))))))
-
-(assert (equal? 0.0 (+ 0.0 0))) ; tests that + no longer does inexact->exact
-
-(assert (equal? 1.0 (* 1.0 1))) ; tests that * no longer does inexact->exact
-
-(define (with-output-to-string nada thunk)
- (let ((b (buffer)))
- (with-output-to b (thunk))
- (io.tostring! b)))
-
-(let ((c #\a))
- (assert (equal? (with-output-to-string #f (lambda () (print (list c c))))
- "(#\\a #\\a)")))
-
-(assert-fail (eval '(set! (car (cons 1 2)) 3)))
-
-(princ "all tests pass\n")
-#t
--- a/tests/wt.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-(define (tw)
- (set! i 0)
- (while (< i 10000000) (set! i (+ i 1))))
-
-(define (tw2)
- (letrec ((loop (lambda ()
- (if (< i 10000000)
- (begin (set! i (+ i 1))
- (loop))
- ()))))
- (loop)))
-
-#|
-interpreter:
-while: 1.82sec
-macro: 2.98sec
-
-compiler:
-while: 0.72sec
-macro: 1.24sec
-|#