ref: 24a71723ffbe92ccbdc088a078d776fb869b52ca
parent: 30075dcfce532093f7b9001b3378fe3bc0e81176
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Fri Mar 21 18:32:01 EDT 2025
lsp → sl
--- a/.gitignore
+++ b/.gitignore
@@ -2,9 +2,9 @@
[05678qvtoa].*
*.out
*.bak
-instructions.lsp
-builtins.lsp
-docs_ops.lsp
+instructions.sl
+builtins.sl
+docs_ops.sl
builtin_fns.h
*.core
sl.boot.s
--- a/meson.build
+++ b/meson.build
@@ -382,18 +382,18 @@
src_dir = meson.current_source_dir()
tests_dir = join_paths(src_dir, 'test')
-test('100x100.lsp', sl, args: ['100x100.lsp'], workdir: tests_dir)-test('argv.lsp', sl, args: ['argv.lsp'], workdir: tests_dir)-test('exit0.lsp', sl, args: ['exit0.lsp'], workdir: tests_dir)-test('exit1.lsp', sl, args: ['exit1.lsp'], workdir: tests_dir, should_fail: true)-test('bench.lsp', sl, args: ['bench.lsp'], workdir: tests_dir, timeout: -1)-test('hashtest.lsp', sl, args: ['hashtest.lsp'], workdir: tests_dir)-test('mp.lsp', sl, args: ['mp.lsp'], workdir: tests_dir)-test('perf.lsp', sl, args: ['perf.lsp'], workdir: tests_dir, timeout: -1)-test('tme.lsp', sl, args: ['tme.lsp'], workdir: tests_dir, timeout: -1)-test('torture.lsp', sl, args: ['-S', '8m', 'torture.lsp'], workdir: tests_dir, timeout: -1)-test('torus.lsp', sl, args: ['torus.lsp'], workdir: tests_dir)-test('unit.lsp', sl, args: ['-S', '1m', 'unittest.lsp'], workdir: tests_dir)+test('100x100.sl', sl, args: ['100x100.sl'], workdir: tests_dir)+test('argv.sl', sl, args: ['argv.sl'], workdir: tests_dir)+test('exit0.sl', sl, args: ['exit0.sl'], workdir: tests_dir)+test('exit1.sl', sl, args: ['exit1.sl'], workdir: tests_dir, should_fail: true)+test('bench.sl', sl, args: ['bench.sl'], workdir: tests_dir, timeout: -1)+test('hashtest.sl', sl, args: ['hashtest.sl'], workdir: tests_dir)+test('mp.sl', sl, args: ['mp.sl'], workdir: tests_dir)+test('perf.sl', sl, args: ['perf.sl'], workdir: tests_dir, timeout: -1)+test('tme.sl', sl, args: ['tme.sl'], workdir: tests_dir, timeout: -1)+test('torture.sl', sl, args: ['-S', '8m', 'torture.sl'], workdir: tests_dir, timeout: -1)+test('torus.sl', sl, args: ['torus.sl'], workdir: tests_dir)+test('unit.sl', sl, args: ['-S', '1m', 'unittest.sl'], workdir: tests_dir)bootstrap = find_program(
'bootstrap.sh',
--- a/mkfile
+++ b/mkfile
@@ -105,14 +105,14 @@
bootstrap:V: $O.out
cd src && \
- ../$O.out ../tools/gen.lsp && \
+ ../$O.out ../tools/gen.sl && \
cp ../boot/sl.boot ../boot/sl.boot.bak && \
- ../$O.out ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/sl.boot.new && \
+ ../$O.out ../tools/mkboot0.sl builtins.sl instructions.sl system.sl compiler.sl > ../boot/sl.boot.new && \
mv ../boot/sl.boot.new ../boot/sl.boot && \
cd .. && \
mk && \
cd boot && \
- ../$O.out ../tools/mkboot1.lsp && \
+ ../$O.out ../tools/mkboot1.sl && \
cd .. && \
mk
--- a/src/compiler.lsp
+++ /dev/null
@@ -1,870 +1,0 @@
-;; code generation state, constant tables, bytecode encoding
-
-(def (make-code-emitter) (vec NIL (table) 0 NIL 0))
-(defmacro (bcode:code b) `(aref ,b 0))
-(defmacro (bcode:ctable b) `(aref ,b 1))
-(defmacro (bcode:nconst b) `(aref ,b 2))
-(defmacro (bcode:cenv b) `(aref ,b 3))
-(defmacro (bcode:sp b) `(aref ,b 4))
-(defmacro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
-
-;; get an index for a referenced value in a bytecode object
-(def (bcode:indexfor b v)
- (let ((const-to-idx (bcode:ctable b))
- (nconst (bcode:nconst b)))
- (if (has? const-to-idx v)
- (get const-to-idx v)
- (begin (put! const-to-idx v nconst)
- (prog1 nconst
- (aset! b 2 (+ nconst 1)))))))
-
-(def (emit e inst . args)
- (def (load? i)
- (member i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet
- (let ((bc (aref e 0)))
- (if (not args)
- (if (and (eq? inst 'car)
- (eq? (car bc) 'cdr))
- (set-car! bc 'cadr)
- (cond ((and (eq? inst 'pop) (load? (car bc)))
- (aset! e 0 (cdr bc)))
- (else
- (aset! e 0 (cons inst bc)))))
- (begin
- (when (memq inst '(loadv loadg setg))
- (set! args (list (bcode:indexfor e (car args)))))
- (let ((longform
- (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
- (loada loada.l) (seta seta.l) (box box.l)))))
- (when (and longform (> (car args) 255))
- (set! inst (cadr longform))))
- (let ((longform
- (assq inst '((loadc loadc.l)))))
- (when (and longform (> (car args) 255))
- (set! inst (cadr longform))))
- (if (eq? inst 'loada)
- (cond ((equal? args '(0))
- (set! inst 'loada0)
- (set! args NIL))
- ((equal? args '(1))
- (set! inst 'loada1)
- (set! args NIL))))
- (if (eq? inst 'loadc)
- (cond ((equal? args '(0))
- (set! inst 'loadc0)
- (set! args NIL))
- ((equal? args '(1))
- (set! inst 'loadc1)
- (set! args NIL))))
-
- (let ((lasti (car bc)))
- (cond ((and (eq? inst 'brn)
- (cond ((eq? lasti 'not)
- (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
- ((eq? lasti 'eq?)
- (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
- (else NIL))))
- (else
- (aset! e 0 (nreconc (cons inst args) bc)))))))
- e))
-
-(defmacro (make-label e) `(gensym))
-(defmacro (mark-label e l) `(emit ,e 'label ,l))
-
-;; convert symbolic bytecode representation to a byte array.
-;; labels are fixed-up.
-(def (encode-byte-code e)
- (let* ((cl (reverse! e))
- (v (list->vec cl))
- (long? (>= (+ (length v) ;; 1 byte for each entry, plus...
- ;; at most half the entries in this vector can be
- ;; instructions accepting 32-bit arguments
- (* 3 (div0 (length v) 2)))
- 65536)))
- (let ((n (length v))
- (i 0)
- (label-to-loc (table))
- (fixup-to-label (table))
- (bcode (buffer))
- (vi NIL)
- (nxt NIL))
- (while (< i n)
- (set! vi (aref v i))
- (if (eq? vi 'label)
- (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
- (set! i (+ i 2)))
- (begin
- (io-write bcode
- (get Instructions
- (if long?
- (case vi
- (jmp 'jmp.l)
- (brne 'brne.l)
- (brnn 'brnn.l)
- (brn 'brn.l)
- (else vi))
- vi)))
- (set! i (+ i 1))
- (set! nxt (and (< i n) (aref v i)))
- (cond ((memq vi '(jmp brne brnn brn))
- (put! fixup-to-label (sizeof bcode) nxt)
- (io-write bcode ((if long? s32 s16) 0))
- (set! i (+ i 1)))
- ((eq? vi 'brbound)
- (io-write bcode (s32 nxt))
- (set! i (+ i 1)))
- ((num? nxt)
- (case vi
- ((loadv.l loadg.l setg.l loada.l seta.l
- argc.l vargc.l call.l tcall.l loadc.l box.l)
- (io-write bcode (s32 nxt))
- (set! i (+ i 1)))
-
- ((optargs keyargs) ; 2 s32 args
- (io-write bcode (s32 nxt))
- (set! i (+ i 1))
- (io-write bcode (s32 (aref v i)))
- (set! i (+ i 1))
- (when (eq? vi 'keyargs)
- (io-write bcode (s32 (aref v i)))
- (set! i (+ i 1))))
-
- (else
- ; other number arguments are always u8
- (io-write bcode (u8 nxt))
- (set! i (+ i 1)))))
- (else NIL)))))
-
- (for-each
- (λ (addr labl)
- (io-seek bcode addr)
- (io-write bcode ((if long? s32 s16)
- (- (get label-to-loc labl) addr))))
- fixup-to-label)
- (io->str bcode))))
-
-(def (const-to-idx-vec e)
- (let ((cvec (vec-alloc (bcode:nconst e))))
- (for-each (λ (val idx) (aset! cvec idx val))
- (bcode:ctable e))
- cvec))
-
-;; variables
-
-(def (vinfo symbol heap? index) (list symbol heap? index))
-(def vinfo:sym car)
-(def vinfo:heap? cadr)
-(def vinfo:index caddr)
-
-(def (quoted? e) (eq? (car e) 'quote))
-
-(def (capture-var! g s)
- (let ((ce (bcode:cenv g)))
- (let ((n (index-of s ce 0)))
- (or n
- (prog1 (length ce)
- (aset! g 3 (nconc ce (list s))))))))
-
-(def (index-of item lst start)
- (cond ((not lst) NIL)
- ((eq? item (car lst)) start)
- (else (index-of item (cdr lst) (+ start 1)))))
-
-(def (in-env? s env)
- (and (cons? env)
- (or (assq s (car env))
- (in-env? s (cdr env)))))
-
-(def (lookup-sym s env lev)
- (if (not env)
- 'global
- (let* ((curr (car env))
- (vi (assq s curr)))
- (if vi
- (cons lev vi)
- (lookup-sym s
- (cdr env)
- (+ lev 1))))))
-
-(def (printable? x) (not (or (io? x)
- (void? x)
- (eof-object? x))))
-
-(def (compile-sym g env s deref)
- (let ((loc (lookup-sym s env 0)))
- (cond ((eq? loc 'global)
- (if (and (const? s)
- (printable? (top-level-value s)))
- (emit g 'loadv (top-level-value s))
- (emit g 'loadg s)))
-
- ((= (car loc) 0)
- (emit g 'loada (vinfo:index (cdr loc)))
- (when (and deref (vinfo:heap? (cdr loc)))
- (emit g 'car)))
-
- (else
- (emit g 'loadc (capture-var! g s))
- (when (and deref (vinfo:heap? (cdr loc)))
- (emit g 'car))))))
-
-(def (compile-aset! g env args)
- (let ((nref (- (length args) 2)))
- (cond ((= nref 1)
- (compile-app g env NIL (cons 'aset! args)))
- ((> nref 1)
- (compile-app g env NIL (cons 'aref (list-head args nref)))
- (let ((nargs (compile-arglist g env (list-tail args nref))))
- (bcode:stack g (- nargs))
- (emit g 'aset!)))
- (else (argc-error 'aset! 3)))))
-
-(def (compile-set! g env s rhs)
- (let ((loc (lookup-sym s env 0)))
- (if (eq? loc 'global)
- (begin (compile-in g env NIL rhs)
- (emit g 'setg s))
- (let ((arg? (= (car loc) 0)))
- (let ((h? (vinfo:heap? (cdr loc)))
- (idx (if arg?
- (vinfo:index (cdr loc))
- (capture-var! g s))))
- (if h?
- (begin (emit g (if arg? 'loada 'loadc) idx)
- (bcode:stack g 1)
- (compile-in g env NIL rhs)
- (bcode:stack g -1)
- (emit g 'set-car!))
-
- (begin (compile-in g env NIL rhs)
- (unless arg? (error (str "internal error: misallocated var " s)))
- (emit g 'seta idx))))))))
-
-(def (box-vars g env)
- (let loop ((e env))
- (when (cons? e)
- (if (cadr (car e))
- (emit g 'box (caddr (car e))))
- (loop (cdr e)))))
-
-;; control flow
-
-(def (compile-if g env tail? x)
- (let ((thenl (make-label g))
- (elsel (make-label g))
- (endl (make-label g))
- (test (cadr x))
- (then (caddr x))
- (else (if (cons? (cdddr x))
- (cadddr x)
- NIL)))
- (cond ((eq? test T)
- (compile-in g env tail? then))
- ((not test)
- (compile-in g env tail? else))
- (else
- (compile-in g env NIL test elsel)
- (emit g 'brn elsel)
- (mark-label g thenl)
- (compile-in g env tail? then)
- (if tail?
- (emit g 'ret)
- (emit g 'jmp endl))
- (mark-label g elsel)
- (compile-in g env tail? else)
- (mark-label g endl)))))
-
-(def (compile-begin g env tail? forms)
- (cond ((atom? forms) (compile-in g env tail? (void)))
- ((atom? (cdr forms))
- (compile-in g env tail? (car forms)))
- (else
- (compile-in g env NIL (car forms))
- (emit g 'pop)
- (compile-begin g env tail? (cdr forms)))))
-
-(def (compile-prog1 g env x)
- (compile-in g env NIL (cadr x))
- (when (cons? (cddr x))
- (bcode:stack g 1)
- (compile-begin g env NIL (cddr x))
- (emit g 'pop)
- (bcode:stack g -1)))
-
-(def (compile-while g env cond body)
- (let ((top (make-label g))
- (end (make-label g)))
- (compile-in g env NIL (void))
- (bcode:stack g 1)
- (mark-label g top)
- (compile-in g env NIL cond)
- (emit g 'brn end)
- (emit g 'pop)
- (bcode:stack g -1)
- (compile-in g env NIL body)
- (emit g 'jmp top)
- (mark-label g end)))
-
-(def (lambda? a)
- (or (eq? a 'λ)
- (eq? a 'lambda)))
-
-(def (1arg-lambda? func)
- (and (cons? func)
- (lambda? (car func))
- (length= (cadr func) 1)))
-
-(def (compile-short-circuit g env tail? forms default branch outl)
- (cond ((atom? forms) (compile-in g env tail? default outl))
- ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl))
- (else
- (let ((end (or outl (make-label g))))
- (compile-in g env NIL (car forms) outl)
- (bcode:stack g 1)
- (unless outl (emit g 'dup))
- (emit g branch end)
- (bcode:stack g -1)
- (unless outl (emit g 'pop))
- (compile-short-circuit g env tail? (cdr forms) default branch outl)
- (unless outl (mark-label g end))))))
-
-(def (compile-and g env tail? forms outl)
- (compile-short-circuit g env tail? forms T 'brn outl))
-(def (compile-or g env tail? forms)
- (compile-short-circuit g env tail? forms NIL 'brnn NIL))
-
-;; calls
-
-(def (compile-arglist g env lst)
- (for-each (λ (a)
- (compile-in g env NIL a)
- (bcode:stack g 1))
- lst)
- (length lst))
-
-(def (argc-error head count)
- (error "compile error: " head " expects " count
- (if (= count 1)
- " argument."
- " arguments.")))
-
-(def builtin->instruction
- (let ((b2i (table num? 'num? cons 'cons
- fixnum? 'fixnum? equal? 'equal?
- eq? 'eq? sym? 'sym?
- div0 'div0 builtin? 'builtin?
- aset! 'aset! - '- not 'not
- apply 'apply atom? 'atom? nan? 'nan?
- set-cdr! 'set-cdr! / '/
- fn? 'fn? vec 'vec
- list 'list bound? 'bound?
- < '< * '* cdr 'cdr cadr 'cadr
- + '+ eqv? 'eqv? compare 'compare aref 'aref
- set-car! 'set-car! car 'car for 'for
- cons? 'cons? = '= vec? 'vec?)))
- (λ (b)
- (get b2i b NIL))))
-
-(def (compile-builtin-call g env tail? x head b nargs)
- (def (num-compare)
- (if (= nargs 0)
- (argc-error b 1)
- (emit g b nargs)))
- (let ((count (get arg-counts b NIL)))
- (when (and count (not (length= (cdr x) count)))
- (argc-error b count))
- (case b ; handle special cases of vararg builtins
- (list (if (= nargs 0)
- (emit g 'loadnil)
- (emit g b nargs)))
- (< (num-compare))
- (= (num-compare))
- (+ (cond ((= nargs 0) (emit g 'load0))
- ((= nargs 2) (emit g 'add2))
- (else (emit g b nargs))))
- (- (cond ((= nargs 0) (argc-error b 1))
- ((= nargs 1) (emit g 'neg))
- ((= nargs 2) (emit g 'sub2))
- (else (emit g b nargs))))
- (* (if (= nargs 0)
- (emit g 'load1)
- (emit g b nargs)))
- (/ (if (= nargs 0)
- (argc-error b 1)
- (emit g b nargs)))
- (vec (if (= nargs 0)
- (emit g 'loadv #())
- (emit g b nargs)))
- (apply (if (< nargs 2)
- (argc-error b 2)
- (emit g (if tail? 'tapply 'apply) nargs)))
- (aref (cond ((= nargs 2) (emit g 'aref2))
- ((> nargs 2) (emit g b (- nargs 3)))
- (else (argc-error b 2))))
- (else (emit g b)))))
-
-(def (inlineable? form)
- (let ((lam (car form)))
- (and (cons? lam)
- (lambda? (car lam))
- (list? (cadr lam))
- (every sym? (cadr lam))
- (not (length> (cadr lam) 255))
- (length= (cadr lam) (length (cdr form))))))
-
-;; compile call to lambda in head position, inlined
-(def (compile-let g env tail? form)
- (let ((lam (car form))
- (args (cdr form))
- (sp (bcode:sp g)))
- (let ((vars (cadr lam))
- (n (compile-arglist g env args)))
- (let ((newvars
- (vars-to-env vars (complex-bindings (caddr lam) vars) sp)))
- (box-vars g newvars)
- (let ((newenv
- (cons (nconc newvars (car env))
- (cdr env))))
- (compile-in g newenv tail? (caddr lam))
- (bcode:stack g (- n))
- (when (and (> n 0) (not tail?))
- (emit g 'shift n)))))))
-
-(def (compile-app g env tail? x)
- (let ((head (car x)))
- (let ((head
- (if (and (sym? head)
- (not (in-env? head env))
- (bound? head)
- (builtin? (top-level-value head)))
- (top-level-value head)
- head)))
- (if (length> (cdr x) 255)
- ;; more than 255 arguments, need long versions of instructions
- (begin (compile-in g env NIL head)
- (bcode:stack g 1)
- (let ((nargs (compile-arglist g env (cdr x))))
- (bcode:stack g (- nargs))
- (emit g (if tail? 'tcall.l 'call.l) nargs)))
- (let ((b (and (builtin? head)
- (builtin->instruction head))))
- (if (and (eq? head 'cadr)
- (not (in-env? head env))
- (equal? (top-level-value 'cadr) cadr)
- (length= x 2))
- (begin (compile-in g env NIL (cadr x))
- (emit g 'cadr))
- (if (and (cons? head)
- (lambda? (car head))
- (inlineable? x))
- (compile-let g env tail? x)
- (begin
- (unless b
- (compile-in g env NIL head)
- (bcode:stack g 1))
- (let ((nargs (compile-arglist g env (cdr x))))
- (bcode:stack g (- nargs))
- (unless b (bcode:stack g -1))
- (if b
- (compile-builtin-call g env tail? x head b nargs)
- (emit g (if tail? 'tcall 'call) nargs)))))))))))
-
-;; lambda, main compilation loop
-
-(def (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
-
-(def (compile-in g env tail? x (outl NIL))
- (cond ((sym? x) (compile-sym g env x T))
- ((atom? x)
- (cond ((eq? x 0) (emit g 'load0))
- ((eq? x 1) (emit g 'load1))
- ((eq? x T) (emit g 'loadt))
- ((not x) (emit g 'loadnil))
- ((void? x) (emit g 'loadvoid))
- ((fits-i8 x) (emit g 'loadi8 x))
- (else (emit g 'loadv x))))
- ((eq? (car x) 'aset!)
- (compile-aset! g env (cdr x)))
- ((or (not (sym? (car x))) (bound? (car x)) (in-env? (car x) env))
- (compile-app g env tail? x))
- (else
- (case (car x)
- (quote (if (self-evaluating? (cadr x))
- (compile-in g env tail? (cadr x))
- (emit g 'loadv (cadr x))))
- (if (compile-if g env tail? x))
- (begin (compile-begin g env tail? (cdr x)))
- (prog1 (compile-prog1 g env x))
- (λ (receive (the-f cenv) (compile-f- env x)
- (begin (emit g 'loadv the-f)
- (when cenv
- (for-each (λ (var)
- (compile-sym g env var NIL))
- cenv)
- (emit g 'closure (length cenv))))))
- (and (compile-and g env tail? (cdr x) outl))
- (or (compile-or g env tail? (cdr x)))
- (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
- (return (compile-in g env T (cadr x))
- (emit g 'ret))
- (set! (let* ((name (cadr x))
- (doc+value (separate-doc-from-body (cddr x)))
- (doc (car (car doc+value)))
- (value (cdr doc+value)))
- (unless (sym? name)
- (error "set!: name must be a symbol"))
- (when doc
- (sym-set-doc name doc (and (cons? (car value))
- (lambda? (car (car value)))
- (lambda:vars (car value)))))
- (compile-set! g env name (car value))))
- (trycatch (compile-in g env NIL `(λ () ,(cadr x)))
- (unless (1arg-lambda? (caddr x))
- (error "trycatch: second form must be a 1-argument lambda"))
- (compile-in g env NIL (caddr x))
- (emit g 'trycatch))
- (else (compile-app g env tail? x))))))
-
-;; optional and keyword args
-
-(def (keyword-arg? x) (and (cons? x) (keyword? (car x))))
-(def (keyword->sym k)
- (if (keyword? k)
- (sym (let ((s (str k)))
- (str-sub s 1 (str-length s))))
- k))
-
-(def (lambda-vars l)
- (def (check-formals l o opt kw)
- (cond ((or (not l) (sym? l)) T)
- ((and (cons? l) (sym? (car l)))
- (if (or opt kw)
- (error "compile error: invalid argument list "
- o ": optional arguments must come after required")
- (check-formals (cdr l) o opt kw)))
- ((and (cons? l) (cons? (car l)))
- (unless (and (length= (car l) 2)
- (sym? (caar l)))
- (error "compile error: invalid optional argument " (car l)
- " in list " o))
- (if (keyword? (caar l))
- (check-formals (cdr l) o opt T)
- (if kw
- (error "compile error: invalid argument list "
- o ": keyword arguments must come last.")
- (check-formals (cdr l) o T kw))))
- ((cons? l)
- (error "compile error: invalid formal argument " (car l)
- " in list " o))
- (else
- (if (eq? l o)
- (error "compile error: invalid argument list " o)
- (error "compile error: invalid formal argument " l
- " in list " o)))))
- (check-formals l l NIL NIL)
- (map (λ (s) (if (cons? s) (keyword->sym (car s)) s))
- (to-proper l)))
-
-(def (emit-optional-arg-inits g env opta vars i)
- ; i is the lexical var index of the opt arg to process next
- (when (cons? opta)
- (let ((nxt (make-label g)))
- (emit g 'brbound i)
- (emit g 'brnn nxt)
- (compile-in g (extend-env env (list-head vars i) NIL) NIL (cadar opta))
- (emit g 'seta i)
- (emit g 'pop)
- (mark-label g nxt)
- (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
-
-;; define
-
-(def (expand-define x)
- ;; expand a single `define` expression to `set!`
- (let* ((form (cadr x))
- (body (if (cons? (cddr x))
- (cddr x)
- (if (sym? form)
- #.void
- (error "compile error: invalid syntax " (print-to-str x))))))
- (if (sym? form)
- `(#.void (set! ,form ,(car body)))
- `(#.void (set! ,(car form)
- (λ ,(cdr form) ,@body . ,(car form)))))))
-
-(def get-defined-vars
- (letrec ((get-defined-vars-
- (λ (expr)
- (cond ((atom? expr) NIL)
- ((and (eq? (car expr) 'def)
- (cons? (cdr expr)))
- (or (and (sym? (cadr expr))
- (list (cadr expr)))
- (and (cons? (cadr expr))
- (sym? (caadr expr))
- (list (caadr expr)))))
- ((eq? (car expr) 'begin)
- (apply nconc (map get-defined-vars- (cdr expr))))
- (else NIL)))))
- (λ (expr) (delete-duplicates (get-defined-vars- expr)))))
-
-(def (lower-define e)
- ;; convert lambda to one body expression and process internal defines
- (def (λ-body e)
- (let* ((B (if (cons? (cddr e))
- (if (cons? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- (void)))
- (V (get-defined-vars B))
- (new-B (lower-define B)))
- (if V
- (cons `(λ ,V ,new-B)
- (map void V))
- new-B)))
- (cond ((or (atom? e) (quoted? e))
- e)
- ((eq? (car e) 'def)
- (lower-define (expand-define e)))
- ((lambda? (car e))
- `(λ ,(cadr e) ,(λ-body e) . ,(lastcdr e)))
- (else
- (map lower-define e))))
-
-;; closure analysis
-
-(def (lambda:body e) (caddr e))
-(def (lambda:vars e) (lambda-vars (cadr e)))
-
-(def (diff s1 s2)
- (cond ((not s1) NIL)
- ((memq (car s1) s2) (diff (cdr s1) s2))
- (else (cons (car s1) (diff (cdr s1) s2)))))
-
-;; bindings that are both captured and set!'d
-(def (complex-bindings- e vars head nested capt setd)
- (cond ((not vars) NIL)
- ((sym? e)
- (when (and nested (memq e vars))
- (put! capt e T)))
- ((or (atom? e) (quoted? e)) NIL)
- ((eq? (car e) 'set!)
- (when (memq (cadr e) vars)
- (put! setd (cadr e) T)
- (if nested (put! capt (cadr e) T)))
- (complex-bindings- (caddr e) vars NIL nested capt setd))
- ((lambda? (car e))
- (complex-bindings- (lambda:body e)
- (diff vars (lambda:vars e))
- NIL
- (or (not head) nested)
- capt setd))
- (else
- (cons (complex-bindings- (car e) vars (inlineable? e) nested capt setd)
- (map (λ (x)
- (complex-bindings- x vars NIL nested capt setd))
- (cdr e))))))
-
-(def (complex-bindings e vars)
- (let ((capt (table))
- (setd (table)))
- (complex-bindings- e vars NIL NIL capt setd)
- (filter (λ (x) (has? capt x))
- (table-keys setd))))
-
-(def (vars-to-env vars cb offs)
- (map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
- vars (iota (length vars))))
-
-(def (extend-env env vars cb)
- (cons (vars-to-env vars cb 0)
- env))
-
-;; main entry points
-
-(def (compile f) (compile-f NIL (lower-define f)))
-
-(def (compile-thunk expr)
- ;; to eval a top-level expression we need to avoid internal define
- (compile-f NIL `(λ () ,(lower-define expr))))
-
-(def (compile-f env f)
- (receive (ff ignore)
- (compile-f- env f)
- ff))
-
-(def (compile-f- env f)
- (def (any-duplicate-kw kw)
- (let ((k (caar kw))
- (rest (cdr kw)))
- (when rest
- (or (any (λ (next) (and (eq? k (car next)) k)) rest)
- (any-duplicate-kw rest)))))
-
- ;; compile lambda expression, assuming defines already lowered
- (let ((g (make-code-emitter))
- (args (cadr f))
- (atail (lastcdr (cadr f)))
- (vars (lambda:vars f))
- (opta (filter cons? (cadr f)))
- (last (lastcdr f)))
- (let* ((name (if (not last) 'λ last))
- (nargs (if (atom? args) 0 (length args)))
- (nreq (- nargs (length opta)))
- (kwa (filter keyword-arg? opta))
- (dupkw (any-duplicate-kw kwa)))
-
- (when dupkw
- (error "compile error: duplicate keyword " dupkw))
-
- ;; emit argument checking prologue
- (when opta
- (if (not kwa)
- (emit g 'optargs nreq
- (if atail (- nargs) nargs))
- (begin
- (bcode:indexfor g (make-perfect-hash-table
- (map cons
- (map car kwa)
- (iota (length kwa)))))
- (emit g 'keyargs nreq (length kwa)
- (if atail (- nargs) nargs))))
- (emit-optional-arg-inits g env opta vars nreq))
-
- (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
- (atail (emit g 'vargc nargs))
- ((not opta) (emit g 'argc nargs)))
-
- (let ((newenv (extend-env env vars (complex-bindings (lambda:body f) vars))))
- (box-vars g (car newenv))
- ;; set initial stack pointer
- (aset! g 4 (+ (length vars) 4))
- ;; compile body and return
- (compile-in g newenv T (lambda:body f))
- (emit g 'ret)
- (values (fn (encode-byte-code (bcode:code g))
- (const-to-idx-vec g)
- name)
- (bcode:cenv g))))))
-
-;; disassembler
-
-(def (ref-s32-LE a i)
- (s32 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8)
- (ash (aref a (+ i 2)) 16)
- (ash (aref a (+ i 3)) 24))))
-
-(def (ref-s16-LE a i)
- (s16 (+ (ash (aref a (+ i 0)) 0)
- (ash (aref a (+ i 1)) 8))))
-
-(def (hex5 n)
- (str-lpad (num->str n 16) 5 #\0))
-
-(def (fn-disasm f (ip NIL) . lev?)
- (when (not lev?)
- (fn-disasm f ip 0)
- (newline)
- (return (void)))
- (let ((lev (car lev?))
- (code (fn-code f))
- (vals (fn-vals f)))
- (def (print-val v)
- (if (and (fn? v) (not (builtin? v)))
- (begin (newline)
- (fn-disasm v NIL (+ lev 1)))
- (print v)))
- (def (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
- " >"
- " ")
- (hex5 (- s 1)) ": "
- inst " "))
- (let ((i 0)
- (N (length code)))
- (while (< i N)
- ; find key whose value matches the current byte
- (let ((inst (table-foldl (λ (k v z)
- (or z (and (= v (aref code i))
- k)))
- NIL Instructions)))
- (when (> i 0) (newline))
- (dotimes (xx lev) (princ "\t"))
- (set! i (+ i 1))
- (case inst
- ((loadv.l loadg.l setg.l)
- (print-inst inst i 4)
- (print-val (aref vals (ref-s32-LE code i)))
- (set! i (+ i 4)))
-
- ((loadv loadg setg)
- (print-inst inst i 1)
- (print-val (aref vals (aref code i)))
- (set! i (+ i 1)))
-
- ((loada seta loadc call tcall list + - * / < = vec
- argc vargc loadi8 apply tapply closure box shift aref)
- (print-inst inst i 1)
- (princ (num->str (+ (aref code i) (if (eq? inst 'aref) 3 0))))
- (set! i (+ i 1)))
-
- ((loada.l seta.l loadc.l argc.l vargc.l call.l tcall.l box.l)
- (print-inst inst i 4)
- (princ (num->str (ref-s32-LE code i)))
- (set! i (+ i 4)))
-
- ((optargs keyargs)
- (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
- (princ (num->str (ref-s32-LE code i)) " ")
- (set! i (+ i 4))
- (princ (num->str (ref-s32-LE code i)))
- (set! i (+ i 4))
- (when (eq? inst 'keyargs)
- (princ " ")
- (princ (num->str (ref-s32-LE code i)) " ")
- (set! i (+ i 4))))
-
- ((brbound)
- (print-inst inst i 4)
- (princ (num->str (ref-s32-LE code i)) " ")
- (set! i (+ i 4)))
-
- ((jmp brne brnn brn)
- (print-inst inst i 2)
- (princ "@" (hex5 (+ i (ref-s16-LE code i))))
- (set! i (+ i 2)))
-
- ((jmp.l brne.l brnn.l brn.l)
- (print-inst inst i 4)
- (princ "@" (hex5 (+ i (ref-s32-LE code i))))
- (set! i (+ i 4)))
-
- (else (print-inst inst i 0))))))))
-
-; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
-; Copyright (C) Marc Feeley 2006. All Rights Reserved.
-;
-; "alist" is a list of pairs of the form "(keyword . value)"
-; The result is a perfect hash-table represented as a vector of
-; length 2*N, where N is the hash modulus. If the keyword K is in
-; the hash-table it is at index
-;
-; X = (* 2 ($hash-keyword K N))
-;
-; and the associated value is at index X+1.
-(def (make-perfect-hash-table alist)
- (def ($hash-keyword key n)
- (mod0 (abs (hash key)) n))
- (let loop1 ((n (length alist)))
- (let ((v (vec-alloc (* 2 n) NIL)))
- (let loop2 ((lst alist))
- (if (cons? lst)
- (let ((key (caar lst)))
- (let ((x (* 2 ($hash-keyword key n))))
- (if (aref v x)
- (loop1 (+ n 1))
- (begin
- (aset! v x key)
- (aset! v (+ x 1) (cdar lst))
- (loop2 (cdr lst))))))
- v)))))
--- /dev/null
+++ b/src/compiler.sl
@@ -1,0 +1,870 @@
+;; code generation state, constant tables, bytecode encoding
+
+(def (make-code-emitter) (vec NIL (table) 0 NIL 0))
+(defmacro (bcode:code b) `(aref ,b 0))
+(defmacro (bcode:ctable b) `(aref ,b 1))
+(defmacro (bcode:nconst b) `(aref ,b 2))
+(defmacro (bcode:cenv b) `(aref ,b 3))
+(defmacro (bcode:sp b) `(aref ,b 4))
+(defmacro (bcode:stack b n) `(aset! ,b 4 (+ (bcode:sp ,b) ,n)))
+
+;; get an index for a referenced value in a bytecode object
+(def (bcode:indexfor b v)
+ (let ((const-to-idx (bcode:ctable b))
+ (nconst (bcode:nconst b)))
+ (if (has? const-to-idx v)
+ (get const-to-idx v)
+ (begin (put! const-to-idx v nconst)
+ (prog1 nconst
+ (aset! b 2 (+ nconst 1)))))))
+
+(def (emit e inst . args)
+ (def (load? i)
+ (member i '(load0 load1 loadt loadf loadnil loadvoid))) ; FIXME no load immediate here yet
+ (let ((bc (aref e 0)))
+ (if (not args)
+ (if (and (eq? inst 'car)
+ (eq? (car bc) 'cdr))
+ (set-car! bc 'cadr)
+ (cond ((and (eq? inst 'pop) (load? (car bc)))
+ (aset! e 0 (cdr bc)))
+ (else
+ (aset! e 0 (cons inst bc)))))
+ (begin
+ (when (memq inst '(loadv loadg setg))
+ (set! args (list (bcode:indexfor e (car args)))))
+ (let ((longform
+ (assq inst '((loadv loadv.l) (loadg loadg.l) (setg setg.l)
+ (loada loada.l) (seta seta.l) (box box.l)))))
+ (when (and longform (> (car args) 255))
+ (set! inst (cadr longform))))
+ (let ((longform
+ (assq inst '((loadc loadc.l)))))
+ (when (and longform (> (car args) 255))
+ (set! inst (cadr longform))))
+ (if (eq? inst 'loada)
+ (cond ((equal? args '(0))
+ (set! inst 'loada0)
+ (set! args NIL))
+ ((equal? args '(1))
+ (set! inst 'loada1)
+ (set! args NIL))))
+ (if (eq? inst 'loadc)
+ (cond ((equal? args '(0))
+ (set! inst 'loadc0)
+ (set! args NIL))
+ ((equal? args '(1))
+ (set! inst 'loadc1)
+ (set! args NIL))))
+
+ (let ((lasti (car bc)))
+ (cond ((and (eq? inst 'brn)
+ (cond ((eq? lasti 'not)
+ (aset! e 0 (cons (car args) (cons 'brnn (cdr bc)))))
+ ((eq? lasti 'eq?)
+ (aset! e 0 (cons (car args) (cons 'brne (cdr bc)))))
+ (else NIL))))
+ (else
+ (aset! e 0 (nreconc (cons inst args) bc)))))))
+ e))
+
+(defmacro (make-label e) `(gensym))
+(defmacro (mark-label e l) `(emit ,e 'label ,l))
+
+;; convert symbolic bytecode representation to a byte array.
+;; labels are fixed-up.
+(def (encode-byte-code e)
+ (let* ((cl (reverse! e))
+ (v (list->vec cl))
+ (long? (>= (+ (length v) ;; 1 byte for each entry, plus...
+ ;; at most half the entries in this vector can be
+ ;; instructions accepting 32-bit arguments
+ (* 3 (div0 (length v) 2)))
+ 65536)))
+ (let ((n (length v))
+ (i 0)
+ (label-to-loc (table))
+ (fixup-to-label (table))
+ (bcode (buffer))
+ (vi NIL)
+ (nxt NIL))
+ (while (< i n)
+ (set! vi (aref v i))
+ (if (eq? vi 'label)
+ (begin (put! label-to-loc (aref v (+ i 1)) (sizeof bcode))
+ (set! i (+ i 2)))
+ (begin
+ (io-write bcode
+ (get Instructions
+ (if long?
+ (case vi
+ (jmp 'jmp.l)
+ (brne 'brne.l)
+ (brnn 'brnn.l)
+ (brn 'brn.l)
+ (else vi))
+ vi)))
+ (set! i (+ i 1))
+ (set! nxt (and (< i n) (aref v i)))
+ (cond ((memq vi '(jmp brne brnn brn))
+ (put! fixup-to-label (sizeof bcode) nxt)
+ (io-write bcode ((if long? s32 s16) 0))
+ (set! i (+ i 1)))
+ ((eq? vi 'brbound)
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1)))
+ ((num? nxt)
+ (case vi
+ ((loadv.l loadg.l setg.l loada.l seta.l
+ argc.l vargc.l call.l tcall.l loadc.l box.l)
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1)))
+
+ ((optargs keyargs) ; 2 s32 args
+ (io-write bcode (s32 nxt))
+ (set! i (+ i 1))
+ (io-write bcode (s32 (aref v i)))
+ (set! i (+ i 1))
+ (when (eq? vi 'keyargs)
+ (io-write bcode (s32 (aref v i)))
+ (set! i (+ i 1))))
+
+ (else
+ ; other number arguments are always u8
+ (io-write bcode (u8 nxt))
+ (set! i (+ i 1)))))
+ (else NIL)))))
+
+ (for-each
+ (λ (addr labl)
+ (io-seek bcode addr)
+ (io-write bcode ((if long? s32 s16)
+ (- (get label-to-loc labl) addr))))
+ fixup-to-label)
+ (io->str bcode))))
+
+(def (const-to-idx-vec e)
+ (let ((cvec (vec-alloc (bcode:nconst e))))
+ (for-each (λ (val idx) (aset! cvec idx val))
+ (bcode:ctable e))
+ cvec))
+
+;; variables
+
+(def (vinfo symbol heap? index) (list symbol heap? index))
+(def vinfo:sym car)
+(def vinfo:heap? cadr)
+(def vinfo:index caddr)
+
+(def (quoted? e) (eq? (car e) 'quote))
+
+(def (capture-var! g s)
+ (let ((ce (bcode:cenv g)))
+ (let ((n (index-of s ce 0)))
+ (or n
+ (prog1 (length ce)
+ (aset! g 3 (nconc ce (list s))))))))
+
+(def (index-of item lst start)
+ (cond ((not lst) NIL)
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
+
+(def (in-env? s env)
+ (and (cons? env)
+ (or (assq s (car env))
+ (in-env? s (cdr env)))))
+
+(def (lookup-sym s env lev)
+ (if (not env)
+ 'global
+ (let* ((curr (car env))
+ (vi (assq s curr)))
+ (if vi
+ (cons lev vi)
+ (lookup-sym s
+ (cdr env)
+ (+ lev 1))))))
+
+(def (printable? x) (not (or (io? x)
+ (void? x)
+ (eof-object? x))))
+
+(def (compile-sym g env s deref)
+ (let ((loc (lookup-sym s env 0)))
+ (cond ((eq? loc 'global)
+ (if (and (const? s)
+ (printable? (top-level-value s)))
+ (emit g 'loadv (top-level-value s))
+ (emit g 'loadg s)))
+
+ ((= (car loc) 0)
+ (emit g 'loada (vinfo:index (cdr loc)))
+ (when (and deref (vinfo:heap? (cdr loc)))
+ (emit g 'car)))
+
+ (else
+ (emit g 'loadc (capture-var! g s))
+ (when (and deref (vinfo:heap? (cdr loc)))
+ (emit g 'car))))))
+
+(def (compile-aset! g env args)
+ (let ((nref (- (length args) 2)))
+ (cond ((= nref 1)
+ (compile-app g env NIL (cons 'aset! args)))
+ ((> nref 1)
+ (compile-app g env NIL (cons 'aref (list-head args nref)))
+ (let ((nargs (compile-arglist g env (list-tail args nref))))
+ (bcode:stack g (- nargs))
+ (emit g 'aset!)))
+ (else (argc-error 'aset! 3)))))
+
+(def (compile-set! g env s rhs)
+ (let ((loc (lookup-sym s env 0)))
+ (if (eq? loc 'global)
+ (begin (compile-in g env NIL rhs)
+ (emit g 'setg s))
+ (let ((arg? (= (car loc) 0)))
+ (let ((h? (vinfo:heap? (cdr loc)))
+ (idx (if arg?
+ (vinfo:index (cdr loc))
+ (capture-var! g s))))
+ (if h?
+ (begin (emit g (if arg? 'loada 'loadc) idx)
+ (bcode:stack g 1)
+ (compile-in g env NIL rhs)
+ (bcode:stack g -1)
+ (emit g 'set-car!))
+
+ (begin (compile-in g env NIL rhs)
+ (unless arg? (error (str "internal error: misallocated var " s)))
+ (emit g 'seta idx))))))))
+
+(def (box-vars g env)
+ (let loop ((e env))
+ (when (cons? e)
+ (if (cadr (car e))
+ (emit g 'box (caddr (car e))))
+ (loop (cdr e)))))
+
+;; control flow
+
+(def (compile-if g env tail? x)
+ (let ((thenl (make-label g))
+ (elsel (make-label g))
+ (endl (make-label g))
+ (test (cadr x))
+ (then (caddr x))
+ (else (if (cons? (cdddr x))
+ (cadddr x)
+ NIL)))
+ (cond ((eq? test T)
+ (compile-in g env tail? then))
+ ((not test)
+ (compile-in g env tail? else))
+ (else
+ (compile-in g env NIL test elsel)
+ (emit g 'brn elsel)
+ (mark-label g thenl)
+ (compile-in g env tail? then)
+ (if tail?
+ (emit g 'ret)
+ (emit g 'jmp endl))
+ (mark-label g elsel)
+ (compile-in g env tail? else)
+ (mark-label g endl)))))
+
+(def (compile-begin g env tail? forms)
+ (cond ((atom? forms) (compile-in g env tail? (void)))
+ ((atom? (cdr forms))
+ (compile-in g env tail? (car forms)))
+ (else
+ (compile-in g env NIL (car forms))
+ (emit g 'pop)
+ (compile-begin g env tail? (cdr forms)))))
+
+(def (compile-prog1 g env x)
+ (compile-in g env NIL (cadr x))
+ (when (cons? (cddr x))
+ (bcode:stack g 1)
+ (compile-begin g env NIL (cddr x))
+ (emit g 'pop)
+ (bcode:stack g -1)))
+
+(def (compile-while g env cond body)
+ (let ((top (make-label g))
+ (end (make-label g)))
+ (compile-in g env NIL (void))
+ (bcode:stack g 1)
+ (mark-label g top)
+ (compile-in g env NIL cond)
+ (emit g 'brn end)
+ (emit g 'pop)
+ (bcode:stack g -1)
+ (compile-in g env NIL body)
+ (emit g 'jmp top)
+ (mark-label g end)))
+
+(def (lambda? a)
+ (or (eq? a 'λ)
+ (eq? a 'lambda)))
+
+(def (1arg-lambda? func)
+ (and (cons? func)
+ (lambda? (car func))
+ (length= (cadr func) 1)))
+
+(def (compile-short-circuit g env tail? forms default branch outl)
+ (cond ((atom? forms) (compile-in g env tail? default outl))
+ ((atom? (cdr forms)) (compile-in g env tail? (car forms) outl))
+ (else
+ (let ((end (or outl (make-label g))))
+ (compile-in g env NIL (car forms) outl)
+ (bcode:stack g 1)
+ (unless outl (emit g 'dup))
+ (emit g branch end)
+ (bcode:stack g -1)
+ (unless outl (emit g 'pop))
+ (compile-short-circuit g env tail? (cdr forms) default branch outl)
+ (unless outl (mark-label g end))))))
+
+(def (compile-and g env tail? forms outl)
+ (compile-short-circuit g env tail? forms T 'brn outl))
+(def (compile-or g env tail? forms)
+ (compile-short-circuit g env tail? forms NIL 'brnn NIL))
+
+;; calls
+
+(def (compile-arglist g env lst)
+ (for-each (λ (a)
+ (compile-in g env NIL a)
+ (bcode:stack g 1))
+ lst)
+ (length lst))
+
+(def (argc-error head count)
+ (error "compile error: " head " expects " count
+ (if (= count 1)
+ " argument."
+ " arguments.")))
+
+(def builtin->instruction
+ (let ((b2i (table num? 'num? cons 'cons
+ fixnum? 'fixnum? equal? 'equal?
+ eq? 'eq? sym? 'sym?
+ div0 'div0 builtin? 'builtin?
+ aset! 'aset! - '- not 'not
+ apply 'apply atom? 'atom? nan? 'nan?
+ set-cdr! 'set-cdr! / '/
+ fn? 'fn? vec 'vec
+ list 'list bound? 'bound?
+ < '< * '* cdr 'cdr cadr 'cadr
+ + '+ eqv? 'eqv? compare 'compare aref 'aref
+ set-car! 'set-car! car 'car for 'for
+ cons? 'cons? = '= vec? 'vec?)))
+ (λ (b)
+ (get b2i b NIL))))
+
+(def (compile-builtin-call g env tail? x head b nargs)
+ (def (num-compare)
+ (if (= nargs 0)
+ (argc-error b 1)
+ (emit g b nargs)))
+ (let ((count (get arg-counts b NIL)))
+ (when (and count (not (length= (cdr x) count)))
+ (argc-error b count))
+ (case b ; handle special cases of vararg builtins
+ (list (if (= nargs 0)
+ (emit g 'loadnil)
+ (emit g b nargs)))
+ (< (num-compare))
+ (= (num-compare))
+ (+ (cond ((= nargs 0) (emit g 'load0))
+ ((= nargs 2) (emit g 'add2))
+ (else (emit g b nargs))))
+ (- (cond ((= nargs 0) (argc-error b 1))
+ ((= nargs 1) (emit g 'neg))
+ ((= nargs 2) (emit g 'sub2))
+ (else (emit g b nargs))))
+ (* (if (= nargs 0)
+ (emit g 'load1)
+ (emit g b nargs)))
+ (/ (if (= nargs 0)
+ (argc-error b 1)
+ (emit g b nargs)))
+ (vec (if (= nargs 0)
+ (emit g 'loadv #())
+ (emit g b nargs)))
+ (apply (if (< nargs 2)
+ (argc-error b 2)
+ (emit g (if tail? 'tapply 'apply) nargs)))
+ (aref (cond ((= nargs 2) (emit g 'aref2))
+ ((> nargs 2) (emit g b (- nargs 3)))
+ (else (argc-error b 2))))
+ (else (emit g b)))))
+
+(def (inlineable? form)
+ (let ((lam (car form)))
+ (and (cons? lam)
+ (lambda? (car lam))
+ (list? (cadr lam))
+ (every sym? (cadr lam))
+ (not (length> (cadr lam) 255))
+ (length= (cadr lam) (length (cdr form))))))
+
+;; compile call to lambda in head position, inlined
+(def (compile-let g env tail? form)
+ (let ((lam (car form))
+ (args (cdr form))
+ (sp (bcode:sp g)))
+ (let ((vars (cadr lam))
+ (n (compile-arglist g env args)))
+ (let ((newvars
+ (vars-to-env vars (complex-bindings (caddr lam) vars) sp)))
+ (box-vars g newvars)
+ (let ((newenv
+ (cons (nconc newvars (car env))
+ (cdr env))))
+ (compile-in g newenv tail? (caddr lam))
+ (bcode:stack g (- n))
+ (when (and (> n 0) (not tail?))
+ (emit g 'shift n)))))))
+
+(def (compile-app g env tail? x)
+ (let ((head (car x)))
+ (let ((head
+ (if (and (sym? head)
+ (not (in-env? head env))
+ (bound? head)
+ (builtin? (top-level-value head)))
+ (top-level-value head)
+ head)))
+ (if (length> (cdr x) 255)
+ ;; more than 255 arguments, need long versions of instructions
+ (begin (compile-in g env NIL head)
+ (bcode:stack g 1)
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (bcode:stack g (- nargs))
+ (emit g (if tail? 'tcall.l 'call.l) nargs)))
+ (let ((b (and (builtin? head)
+ (builtin->instruction head))))
+ (if (and (eq? head 'cadr)
+ (not (in-env? head env))
+ (equal? (top-level-value 'cadr) cadr)
+ (length= x 2))
+ (begin (compile-in g env NIL (cadr x))
+ (emit g 'cadr))
+ (if (and (cons? head)
+ (lambda? (car head))
+ (inlineable? x))
+ (compile-let g env tail? x)
+ (begin
+ (unless b
+ (compile-in g env NIL head)
+ (bcode:stack g 1))
+ (let ((nargs (compile-arglist g env (cdr x))))
+ (bcode:stack g (- nargs))
+ (unless b (bcode:stack g -1))
+ (if b
+ (compile-builtin-call g env tail? x head b nargs)
+ (emit g (if tail? 'tcall 'call) nargs)))))))))))
+
+;; lambda, main compilation loop
+
+(def (fits-i8 x) (and (fixnum? x) (>= 127 x -128)))
+
+(def (compile-in g env tail? x (outl NIL))
+ (cond ((sym? x) (compile-sym g env x T))
+ ((atom? x)
+ (cond ((eq? x 0) (emit g 'load0))
+ ((eq? x 1) (emit g 'load1))
+ ((eq? x T) (emit g 'loadt))
+ ((not x) (emit g 'loadnil))
+ ((void? x) (emit g 'loadvoid))
+ ((fits-i8 x) (emit g 'loadi8 x))
+ (else (emit g 'loadv x))))
+ ((eq? (car x) 'aset!)
+ (compile-aset! g env (cdr x)))
+ ((or (not (sym? (car x))) (bound? (car x)) (in-env? (car x) env))
+ (compile-app g env tail? x))
+ (else
+ (case (car x)
+ (quote (if (self-evaluating? (cadr x))
+ (compile-in g env tail? (cadr x))
+ (emit g 'loadv (cadr x))))
+ (if (compile-if g env tail? x))
+ (begin (compile-begin g env tail? (cdr x)))
+ (prog1 (compile-prog1 g env x))
+ (λ (receive (the-f cenv) (compile-f- env x)
+ (begin (emit g 'loadv the-f)
+ (when cenv
+ (for-each (λ (var)
+ (compile-sym g env var NIL))
+ cenv)
+ (emit g 'closure (length cenv))))))
+ (and (compile-and g env tail? (cdr x) outl))
+ (or (compile-or g env tail? (cdr x)))
+ (while (compile-while g env (cadr x) (cons 'begin (cddr x))))
+ (return (compile-in g env T (cadr x))
+ (emit g 'ret))
+ (set! (let* ((name (cadr x))
+ (doc+value (separate-doc-from-body (cddr x)))
+ (doc (car (car doc+value)))
+ (value (cdr doc+value)))
+ (unless (sym? name)
+ (error "set!: name must be a symbol"))
+ (when doc
+ (sym-set-doc name doc (and (cons? (car value))
+ (lambda? (car (car value)))
+ (lambda:vars (car value)))))
+ (compile-set! g env name (car value))))
+ (trycatch (compile-in g env NIL `(λ () ,(cadr x)))
+ (unless (1arg-lambda? (caddr x))
+ (error "trycatch: second form must be a 1-argument lambda"))
+ (compile-in g env NIL (caddr x))
+ (emit g 'trycatch))
+ (else (compile-app g env tail? x))))))
+
+;; optional and keyword args
+
+(def (keyword-arg? x) (and (cons? x) (keyword? (car x))))
+(def (keyword->sym k)
+ (if (keyword? k)
+ (sym (let ((s (str k)))
+ (str-sub s 1 (str-length s))))
+ k))
+
+(def (lambda-vars l)
+ (def (check-formals l o opt kw)
+ (cond ((or (not l) (sym? l)) T)
+ ((and (cons? l) (sym? (car l)))
+ (if (or opt kw)
+ (error "compile error: invalid argument list "
+ o ": optional arguments must come after required")
+ (check-formals (cdr l) o opt kw)))
+ ((and (cons? l) (cons? (car l)))
+ (unless (and (length= (car l) 2)
+ (sym? (caar l)))
+ (error "compile error: invalid optional argument " (car l)
+ " in list " o))
+ (if (keyword? (caar l))
+ (check-formals (cdr l) o opt T)
+ (if kw
+ (error "compile error: invalid argument list "
+ o ": keyword arguments must come last.")
+ (check-formals (cdr l) o T kw))))
+ ((cons? l)
+ (error "compile error: invalid formal argument " (car l)
+ " in list " o))
+ (else
+ (if (eq? l o)
+ (error "compile error: invalid argument list " o)
+ (error "compile error: invalid formal argument " l
+ " in list " o)))))
+ (check-formals l l NIL NIL)
+ (map (λ (s) (if (cons? s) (keyword->sym (car s)) s))
+ (to-proper l)))
+
+(def (emit-optional-arg-inits g env opta vars i)
+ ; i is the lexical var index of the opt arg to process next
+ (when (cons? opta)
+ (let ((nxt (make-label g)))
+ (emit g 'brbound i)
+ (emit g 'brnn nxt)
+ (compile-in g (extend-env env (list-head vars i) NIL) NIL (cadar opta))
+ (emit g 'seta i)
+ (emit g 'pop)
+ (mark-label g nxt)
+ (emit-optional-arg-inits g env (cdr opta) vars (+ i 1)))))
+
+;; define
+
+(def (expand-define x)
+ ;; expand a single `define` expression to `set!`
+ (let* ((form (cadr x))
+ (body (if (cons? (cddr x))
+ (cddr x)
+ (if (sym? form)
+ #.void
+ (error "compile error: invalid syntax " (print-to-str x))))))
+ (if (sym? form)
+ `(#.void (set! ,form ,(car body)))
+ `(#.void (set! ,(car form)
+ (λ ,(cdr form) ,@body . ,(car form)))))))
+
+(def get-defined-vars
+ (letrec ((get-defined-vars-
+ (λ (expr)
+ (cond ((atom? expr) NIL)
+ ((and (eq? (car expr) 'def)
+ (cons? (cdr expr)))
+ (or (and (sym? (cadr expr))
+ (list (cadr expr)))
+ (and (cons? (cadr expr))
+ (sym? (caadr expr))
+ (list (caadr expr)))))
+ ((eq? (car expr) 'begin)
+ (apply nconc (map get-defined-vars- (cdr expr))))
+ (else NIL)))))
+ (λ (expr) (delete-duplicates (get-defined-vars- expr)))))
+
+(def (lower-define e)
+ ;; convert lambda to one body expression and process internal defines
+ (def (λ-body e)
+ (let* ((B (if (cons? (cddr e))
+ (if (cons? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ (void)))
+ (V (get-defined-vars B))
+ (new-B (lower-define B)))
+ (if V
+ (cons `(λ ,V ,new-B)
+ (map void V))
+ new-B)))
+ (cond ((or (atom? e) (quoted? e))
+ e)
+ ((eq? (car e) 'def)
+ (lower-define (expand-define e)))
+ ((lambda? (car e))
+ `(λ ,(cadr e) ,(λ-body e) . ,(lastcdr e)))
+ (else
+ (map lower-define e))))
+
+;; closure analysis
+
+(def (lambda:body e) (caddr e))
+(def (lambda:vars e) (lambda-vars (cadr e)))
+
+(def (diff s1 s2)
+ (cond ((not s1) NIL)
+ ((memq (car s1) s2) (diff (cdr s1) s2))
+ (else (cons (car s1) (diff (cdr s1) s2)))))
+
+;; bindings that are both captured and set!'d
+(def (complex-bindings- e vars head nested capt setd)
+ (cond ((not vars) NIL)
+ ((sym? e)
+ (when (and nested (memq e vars))
+ (put! capt e T)))
+ ((or (atom? e) (quoted? e)) NIL)
+ ((eq? (car e) 'set!)
+ (when (memq (cadr e) vars)
+ (put! setd (cadr e) T)
+ (if nested (put! capt (cadr e) T)))
+ (complex-bindings- (caddr e) vars NIL nested capt setd))
+ ((lambda? (car e))
+ (complex-bindings- (lambda:body e)
+ (diff vars (lambda:vars e))
+ NIL
+ (or (not head) nested)
+ capt setd))
+ (else
+ (cons (complex-bindings- (car e) vars (inlineable? e) nested capt setd)
+ (map (λ (x)
+ (complex-bindings- x vars NIL nested capt setd))
+ (cdr e))))))
+
+(def (complex-bindings e vars)
+ (let ((capt (table))
+ (setd (table)))
+ (complex-bindings- e vars NIL NIL capt setd)
+ (filter (λ (x) (has? capt x))
+ (table-keys setd))))
+
+(def (vars-to-env vars cb offs)
+ (map (λ (var i) (vinfo var (not (not (memq var cb))) (+ i offs)))
+ vars (iota (length vars))))
+
+(def (extend-env env vars cb)
+ (cons (vars-to-env vars cb 0)
+ env))
+
+;; main entry points
+
+(def (compile f) (compile-f NIL (lower-define f)))
+
+(def (compile-thunk expr)
+ ;; to eval a top-level expression we need to avoid internal define
+ (compile-f NIL `(λ () ,(lower-define expr))))
+
+(def (compile-f env f)
+ (receive (ff ignore)
+ (compile-f- env f)
+ ff))
+
+(def (compile-f- env f)
+ (def (any-duplicate-kw kw)
+ (let ((k (caar kw))
+ (rest (cdr kw)))
+ (when rest
+ (or (any (λ (next) (and (eq? k (car next)) k)) rest)
+ (any-duplicate-kw rest)))))
+
+ ;; compile lambda expression, assuming defines already lowered
+ (let ((g (make-code-emitter))
+ (args (cadr f))
+ (atail (lastcdr (cadr f)))
+ (vars (lambda:vars f))
+ (opta (filter cons? (cadr f)))
+ (last (lastcdr f)))
+ (let* ((name (if (not last) 'λ last))
+ (nargs (if (atom? args) 0 (length args)))
+ (nreq (- nargs (length opta)))
+ (kwa (filter keyword-arg? opta))
+ (dupkw (any-duplicate-kw kwa)))
+
+ (when dupkw
+ (error "compile error: duplicate keyword " dupkw))
+
+ ;; emit argument checking prologue
+ (when opta
+ (if (not kwa)
+ (emit g 'optargs nreq
+ (if atail (- nargs) nargs))
+ (begin
+ (bcode:indexfor g (make-perfect-hash-table
+ (map cons
+ (map car kwa)
+ (iota (length kwa)))))
+ (emit g 'keyargs nreq (length kwa)
+ (if atail (- nargs) nargs))))
+ (emit-optional-arg-inits g env opta vars nreq))
+
+ (cond ((> nargs 255) (emit g (if atail 'vargc.l 'argc.l) nargs))
+ (atail (emit g 'vargc nargs))
+ ((not opta) (emit g 'argc nargs)))
+
+ (let ((newenv (extend-env env vars (complex-bindings (lambda:body f) vars))))
+ (box-vars g (car newenv))
+ ;; set initial stack pointer
+ (aset! g 4 (+ (length vars) 4))
+ ;; compile body and return
+ (compile-in g newenv T (lambda:body f))
+ (emit g 'ret)
+ (values (fn (encode-byte-code (bcode:code g))
+ (const-to-idx-vec g)
+ name)
+ (bcode:cenv g))))))
+
+;; disassembler
+
+(def (ref-s32-LE a i)
+ (s32 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8)
+ (ash (aref a (+ i 2)) 16)
+ (ash (aref a (+ i 3)) 24))))
+
+(def (ref-s16-LE a i)
+ (s16 (+ (ash (aref a (+ i 0)) 0)
+ (ash (aref a (+ i 1)) 8))))
+
+(def (hex5 n)
+ (str-lpad (num->str n 16) 5 #\0))
+
+(def (fn-disasm f (ip NIL) . lev?)
+ (when (not lev?)
+ (fn-disasm f ip 0)
+ (newline)
+ (return (void)))
+ (let ((lev (car lev?))
+ (code (fn-code f))
+ (vals (fn-vals f)))
+ (def (print-val v)
+ (if (and (fn? v) (not (builtin? v)))
+ (begin (newline)
+ (fn-disasm v NIL (+ lev 1)))
+ (print v)))
+ (def (print-inst inst s sz) (princ (if (and ip (= lev 0) (>= ip (1- s)) (< ip (+ s sz)))
+ " >"
+ " ")
+ (hex5 (- s 1)) ": "
+ inst " "))
+ (let ((i 0)
+ (N (length code)))
+ (while (< i N)
+ ; find key whose value matches the current byte
+ (let ((inst (table-foldl (λ (k v z)
+ (or z (and (= v (aref code i))
+ k)))
+ NIL Instructions)))
+ (when (> i 0) (newline))
+ (dotimes (xx lev) (princ "\t"))
+ (set! i (+ i 1))
+ (case inst
+ ((loadv.l loadg.l setg.l)
+ (print-inst inst i 4)
+ (print-val (aref vals (ref-s32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((loadv loadg setg)
+ (print-inst inst i 1)
+ (print-val (aref vals (aref code i)))
+ (set! i (+ i 1)))
+
+ ((loada seta loadc call tcall list + - * / < = vec
+ argc vargc loadi8 apply tapply closure box shift aref)
+ (print-inst inst i 1)
+ (princ (num->str (+ (aref code i) (if (eq? inst 'aref) 3 0))))
+ (set! i (+ i 1)))
+
+ ((loada.l seta.l loadc.l argc.l vargc.l call.l tcall.l box.l)
+ (print-inst inst i 4)
+ (princ (num->str (ref-s32-LE code i)))
+ (set! i (+ i 4)))
+
+ ((optargs keyargs)
+ (print-inst inst i (+ 8 (if (eq? inst 'keyargs) 4 0)))
+ (princ (num->str (ref-s32-LE code i)) " ")
+ (set! i (+ i 4))
+ (princ (num->str (ref-s32-LE code i)))
+ (set! i (+ i 4))
+ (when (eq? inst 'keyargs)
+ (princ " ")
+ (princ (num->str (ref-s32-LE code i)) " ")
+ (set! i (+ i 4))))
+
+ ((brbound)
+ (print-inst inst i 4)
+ (princ (num->str (ref-s32-LE code i)) " ")
+ (set! i (+ i 4)))
+
+ ((jmp brne brnn brn)
+ (print-inst inst i 2)
+ (princ "@" (hex5 (+ i (ref-s16-LE code i))))
+ (set! i (+ i 2)))
+
+ ((jmp.l brne.l brnn.l brn.l)
+ (print-inst inst i 4)
+ (princ "@" (hex5 (+ i (ref-s32-LE code i))))
+ (set! i (+ i 4)))
+
+ (else (print-inst inst i 0))))))))
+
+; From SRFI 89 by Marc Feeley (http://srfi.schemers.org/srfi-89/srfi-89.html)
+; Copyright (C) Marc Feeley 2006. All Rights Reserved.
+;
+; "alist" is a list of pairs of the form "(keyword . value)"
+; The result is a perfect hash-table represented as a vector of
+; length 2*N, where N is the hash modulus. If the keyword K is in
+; the hash-table it is at index
+;
+; X = (* 2 ($hash-keyword K N))
+;
+; and the associated value is at index X+1.
+(def (make-perfect-hash-table alist)
+ (def ($hash-keyword key n)
+ (mod0 (abs (hash key)) n))
+ (let loop1 ((n (length alist)))
+ (let ((v (vec-alloc (* 2 n) NIL)))
+ (let loop2 ((lst alist))
+ (if (cons? lst)
+ (let ((key (caar lst)))
+ (let ((x (* 2 ($hash-keyword key n))))
+ (if (aref v x)
+ (loop1 (+ n 1))
+ (begin
+ (aset! v x key)
+ (aset! v (+ x 1) (cdar lst))
+ (loop2 (cdr lst))))))
+ v)))))
--- a/src/docs_extra.lsp
+++ /dev/null
@@ -1,119 +1,0 @@
-(defmacro (doc-for term . doc)
- "Define documentation for a top level term.
-
- If `term` is a function signature and `doc` is not specified, just
- the signature will be included in the documentation, without
- replacing any previously defined."
- (let* ((call (cons? term))
- (sym (or (and call (car term))
- term))
- (callvars (and call (cdr term))))
- (if call
- `(sym-set-doc ',sym ',doc ',callvars)
- `(sym-set-doc ',sym ',doc))))
-
-(doc-for (vm-stats)
- "Print various VM-related information, such as the number of GC
- calls so far, heap and stack size, etc.")
-
-(doc-for (lz-pack data (level 0))
- "Return data compressed using Lempel-Ziv.
-
- The data must be an array, returned value will have the same type.
- The optional `level` is between `0` and `10`. With `level` set to
- `0` a simple LZSS using hashing will be performed. Levels between
- `1` and `9` offer a trade-off between time/space and ratio. Level
- `10` is optimal but very slow.")
-
-(doc-for (lz-unpack data :to destination))
-(doc-for (lz-unpack data :size decompressed-bytes)
- "Return decompressed data previously compressed using lz-pack.
-
- Either destination for the decompressed data or the expected size of
- the decompressed data must be specified. In the latter case a new
- array is allocated.")
-
-(doc-for (rand)
- "Return a random non-negative fixnum on its maximum range.")
-
-(doc-for (rand-u64)
- "Return a random integer on interval [0, 2⁶⁴-1].")
-
-(doc-for (rand-u32)
- "Return a random integer on interval [0, 2³²-1].")
-
-(doc-for (rand-double)
- "Return a random double on interval [0.0, 1.0].")
-
-(doc-for (rand-float)
- "Return a random float on [0.0, 1.0] interval.")
-
-(doc-for (exit (status NIL))
- "Terminate the process with the specified status. Does not return.
- The status is expected to be a string in case of an error.
-
- Examples:
-
- (exit)
- (exit \"error\")")
-
-(doc-for (file path (:read NIL)
- (:write NIL)
- (:create NIL)
- (:truncate NIL)
- (:append NIL))
- "Open a file for I/O.
-
- An `io` object is returned. Without any modes specified the file
- is opened in read-only mode.")
-
-(doc-for (io? term)
- "Return `T` if `term` is of `io` type, `NIL` otherwise.")
-
-(doc-for (io->str io)
- "Return an in-memory `io` buffer converted to a string.")
-
-(doc-for (io-eof? io)
- "Return `T` if `io` is currently in the \"end of file\" state, `NIL`
- otherwise.")
-
-(doc-for (eof-object? term)
- "Return `T` if `term` is `#<eof>`, `NIL` otherwise.
-
- This object is returned by I/O functions to signal end of file,
- where applicable.")
-
-(doc-for (buffer)
- "Return an in-memory buffer for I/O, of `io` type.
-
- A buffer can be used for both reading and writing at the same
- time.")
-
-(doc-for NIL
- "An empty list. Also used as the opposite of T.
-
- Examples:
-
- (not NIL) → T
- (if NIL 'yes 'no) → no
- (car NIL) → NIL
- (cdr NIL) → NIL")
-
-(doc-for T
- "A boolean \"true\".
-
- Examples:
-
- (not T) → NIL
- (if T 'yes 'no) → yes")
-
-(doc-for (str . term)
- "Convert terms to a concatenated string.
-
- This is equivalent to `(princ terms…)`, except the string is
- returned, rather than printed.")
-
-(doc-for (sym . term)
- "Convert terms to a symbol.
-
- This is equivalent to `(sym (str terms…))`.")
--- /dev/null
+++ b/src/docs_extra.sl
@@ -1,0 +1,119 @@
+(defmacro (doc-for term . doc)
+ "Define documentation for a top level term.
+
+ If `term` is a function signature and `doc` is not specified, just
+ the signature will be included in the documentation, without
+ replacing any previously defined."
+ (let* ((call (cons? term))
+ (sym (or (and call (car term))
+ term))
+ (callvars (and call (cdr term))))
+ (if call
+ `(sym-set-doc ',sym ',doc ',callvars)
+ `(sym-set-doc ',sym ',doc))))
+
+(doc-for (vm-stats)
+ "Print various VM-related information, such as the number of GC
+ calls so far, heap and stack size, etc.")
+
+(doc-for (lz-pack data (level 0))
+ "Return data compressed using Lempel-Ziv.
+
+ The data must be an array, returned value will have the same type.
+ The optional `level` is between `0` and `10`. With `level` set to
+ `0` a simple LZSS using hashing will be performed. Levels between
+ `1` and `9` offer a trade-off between time/space and ratio. Level
+ `10` is optimal but very slow.")
+
+(doc-for (lz-unpack data :to destination))
+(doc-for (lz-unpack data :size decompressed-bytes)
+ "Return decompressed data previously compressed using lz-pack.
+
+ Either destination for the decompressed data or the expected size of
+ the decompressed data must be specified. In the latter case a new
+ array is allocated.")
+
+(doc-for (rand)
+ "Return a random non-negative fixnum on its maximum range.")
+
+(doc-for (rand-u64)
+ "Return a random integer on interval [0, 2⁶⁴-1].")
+
+(doc-for (rand-u32)
+ "Return a random integer on interval [0, 2³²-1].")
+
+(doc-for (rand-double)
+ "Return a random double on interval [0.0, 1.0].")
+
+(doc-for (rand-float)
+ "Return a random float on [0.0, 1.0] interval.")
+
+(doc-for (exit (status NIL))
+ "Terminate the process with the specified status. Does not return.
+ The status is expected to be a string in case of an error.
+
+ Examples:
+
+ (exit)
+ (exit \"error\")")
+
+(doc-for (file path (:read NIL)
+ (:write NIL)
+ (:create NIL)
+ (:truncate NIL)
+ (:append NIL))
+ "Open a file for I/O.
+
+ An `io` object is returned. Without any modes specified the file
+ is opened in read-only mode.")
+
+(doc-for (io? term)
+ "Return `T` if `term` is of `io` type, `NIL` otherwise.")
+
+(doc-for (io->str io)
+ "Return an in-memory `io` buffer converted to a string.")
+
+(doc-for (io-eof? io)
+ "Return `T` if `io` is currently in the \"end of file\" state, `NIL`
+ otherwise.")
+
+(doc-for (eof-object? term)
+ "Return `T` if `term` is `#<eof>`, `NIL` otherwise.
+
+ This object is returned by I/O functions to signal end of file,
+ where applicable.")
+
+(doc-for (buffer)
+ "Return an in-memory buffer for I/O, of `io` type.
+
+ A buffer can be used for both reading and writing at the same
+ time.")
+
+(doc-for NIL
+ "An empty list. Also used as the opposite of T.
+
+ Examples:
+
+ (not NIL) → T
+ (if NIL 'yes 'no) → no
+ (car NIL) → NIL
+ (cdr NIL) → NIL")
+
+(doc-for T
+ "A boolean \"true\".
+
+ Examples:
+
+ (not T) → NIL
+ (if T 'yes 'no) → yes")
+
+(doc-for (str . term)
+ "Convert terms to a concatenated string.
+
+ This is equivalent to `(princ terms…)`, except the string is
+ returned, rather than printed.")
+
+(doc-for (sym . term)
+ "Convert terms to a symbol.
+
+ This is equivalent to `(sym (str terms…))`.")
--- a/src/plan9/lsd.lsp
+++ /dev/null
@@ -1,375 +1,0 @@
-#!/bin/sl -i
-
-(defstruct reg name type addr size)
-(defstruct symbol name type addr)
-(defstruct global
- "All the global symbols, separated into text and data symbols.
-
- The text and data fields are both tables from syms to symbols."
- text data)
-(defstruct frame
- "A stack frame. Loc is the enclosing function symbol and instruction
- address of the frame. Retpc is the return instruction address.
- Sp is the stack pointer value. Locals are all the local symbols."
- loc retpc sp locals)
-
-(def coref NIL)
-(def textf NIL)
-(def regsf NIL)
-(def fpregsf NIL)
-(def proc-stdin NIL)
-(def pids NIL)
-(def bptbl (table))
-
-(def (procfile s . flags)
- (when (< pid 0) (error "no active pid"))
- (let ((path (str "/proc/" pid "/" s)))
- (apply file (cons path flags))))
-
-(def (writectl msg)
- (let ((ctlf (procfile 'ctl :write)))
- (io-write ctlf msg)
- (io-close ctlf)))
-
-(def (exited)
- (when (< pid 0) (error "no active pid"))
- (princ "process " pid " exited\n")
- (set! pids (cdr pids))
- (set! pid (if pids (car pids) -1))
- (set! bptbl (table))
- (detach))
-
-(def (readnote)
- (trycatch
- (let* ((notef (procfile 'note :read))
- (note (io-readall notef)))
- (io-close notef)
- note)
- (λ (e) (if (and (eq? (car e) 'io-error)
- (= (str-find (cadr e) "could not open") 0))
- (exited)
- (raise e)))))
-
-(def (start) (writectl "start"))
-(def (startstop) (writectl "startstop") (readnote))
-(def (stop) (writectl "stop") (readnote))
-
-(def (follow addr)
- "Return a list of the next possible executing instructions."
- (lsd-follow addr))
-
-(def (io-pread f off rest)
- (io-seek f off)
- (apply io-read (cons f rest)))
-
-(def (io-pwrite f off rest)
- (io-seek f off)
- (apply io-write (cons f rest))
- (io-flush f))
-
-(def (readcore addr . rest)
- (unless coref (error "not attached to proc"))
- (io-pread coref addr rest))
-
-(def (readtext addr . rest)
- (unless textf (error "not attached to proc"))
- (io-pread textf addr rest))
-
-(def (writecore addr . rest)
- (unless coref (error "not attached to proc"))
- (io-pwrite coref addr rest))
-
-(def (readreg reg)
- (unless regsf (error "not attached to proc"))
- (let ((f (case (reg-type reg)
- ((:gpreg) regsf)
- ((:fpreg) fpregsf))))
- (io-pread f (reg-addr reg) (list (reg-size reg)))))
-
-(def (readsym symbol . rest)
- (unless coref (error "not attached to proc"))
- (apply readcore (cons (symbol-addr symbol) rest)))
-
-(def (hex n) (str "0x" (num->str n 16)))
-
-(def (oct n) (str "0" (num->str n 8)))
-
-(def (bpsave a) (readcore a 'byte (length bpinst)))
-
-(let ((bp_init (λ (loc)
- (when (< pid 0) (error "no running process"))
- (unless (eq? (status) 'Stopped)
- (begin (princ "Waiting... " status "\n")
- (stop)))
- (cond ((sym? loc) (symbol-addr
- (get (global-text globals) loc)))
- ((num? loc) (u64 loc))
- ((symbol? loc) (symbol-addr loc))
- ((str? loc) (filepc loc))
- (else (error "sym|num|symbol|file:line"))))))
- (set! bpset (λ (loc)
- (let ((addr (bp_init loc)))
- (when (has? bptbl addr)
- (error "breakpoint already set at " loc))
- (put! bptbl addr (bpsave addr))
- (writecore addr bpinst))))
- (set! bpdel (λ (loc)
- (let ((addr (bp_init loc)))
- (unless (has? bptbl addr)
- (error "breakpoint not set at " loc))
- (writecore addr (get bptbl addr))
- (del! bptbl addr)))))
-
-(doc-for (bpset loc)
- "Set a breakpoint.
-
- The location can be one of the following:
-
- 1. A sym, in which case the address will be retrieved from
- the global text symbols of the process,
- 2. A num which is the address at which to place the break.
- 3. An LSD symbol in which the case the symbol's address is used.
- 4. A string of the form \"file:line\" which specifies a line in a
- file of source code.
-
- Examples:
-
- `(bpset 'strcpy)` ; breakpoint on strcpy function.
- `(bpset (curPC))` ; breakpoint on current instruction.
- `(bpset \"/sys/src/cmd/cat.c:26\")` ; breakpoint on line 26.")
-
-(doc-for (bpdel loc)
- "Delete a breakpoint.
-
- The location can be one of the following:
-
- 1. A sym, in which case the address will be retrieved from
- the global text symbols of the process,
- 2. A num which is the address at which to place the break.
- 3. An LSD symbol in which the case the symbol's address is used.
- 4. A string of the form \"file:line\" which specifies a line in a
- file of source code.
-
- Examples:
-
- `(bpdel 'strcpy)` ; remove breakpoint on strcpy function.
- `(bpdel (curPC))` ; remove breakpoint on current instruction.
- `(bpdel \"/sys/src/cmd/cat.c:26\")` ; remove breakpoint on line 26.")
-
-(def (detach)
- (when regsf (io-close regsf))
- (when fpregsf (io-close fpregsf))
- (when coref (io-close coref))
- (when textf (io-close textf))
- (void))
-
-(def (attach)
- (detach)
- (set! regsf (procfile 'regs :read :write))
- (set! fpregsf (procfile 'fpregs :read :write))
- (set! coref (procfile 'mem :read :write))
- (set! textf (procfile 'text :read))
- (void))
-
-(def (new . args)
- (let ((v (apply lsd-new args)))
- (when proc-stdin (io-close proc-stdin))
- (set! bptbl (table))
- (set! pid (aref v 0))
- (set! proc-stdin (aref v 1))
- (attach)
- (bpset (car (follow (symbol-addr (get (global-text globals) 'main)))))
- (startstop)
- (set! pids (cons pid pids))
- pid))
-
-(def (lsd a)
- (let* ((v (lsd-load a))
- (f (λ (symbol tbl) (put! tbl (sym (symbol-name symbol)) symbol)))
- (text (foldl f (table) (aref v 3)))
- (data (foldl f (table) (aref v 4))))
- (set! pid (aref v 0))
- (set! registers (aref v 1))
- (set! bpinst (aref v 2))
- (set! globals (make-global :text text :data data)))
- (and (>= pid 0) (attach)))
-
-(def (status)
- (let* ((sf (procfile 'status))
- (stats (read-all sf)))
- (io-close sf)
- (caddr stats)))
-
-(def tracers (table
- "386" (λ () (lsd-ctrace (curPC) (readreg SP) (u64 0)))
- "amd64" (λ () (lsd-ctrace (curPC) (readreg SP) (u64 0)))
- "arm64" (λ () (lsd-ctrace (curPC) (readreg SP) (readreg R30)))))
-
-(def ctrace (get tracers (os-getenv "objtype")))
-
-(def (_stk)
- (reverse!
- (map (λ (f) (frame-locals f (reverse! (frame-locals f))) f)
- (ctrace))))
-
-(def (curPC) (and (>= pid 0) (readreg PC)))
-
-(def (step (n 1))
- "Step `n` assembly instructions. Return the next instruction
- address to be executed or `NIL` if the program has exited."
- (if (= n 0)
- (curPC)
- (let* ((addr (curPC))
- (on-bp (has? bptbl addr)))
- (when on-bp (writecore addr (get bptbl addr)))
- (let* ((f (follow addr))
- (o (map bpsave f)))
- (for-each (λ (a) (writecore a bpinst)) f)
- (startstop)
- (map writecore f o)
- (when on-bp (writecore addr bpinst))
- (step (1- n))))))
-
-(def (cont)
- "Continue program execution. Return the next instruction
- address to be executed or `NIL` if the program has exited."
- (let ((addr (curPC)))
- (when (has? bptbl addr) (step))
- (startstop)
- (curPC)))
-
-(def (func)
- "Continue program execution until the current function returns."
- (let* ((bp (frame-retpc (car (_stk))))
- (o (bpsave bp)))
- (writecore bp bpinst)
- (cont)
- (writecore bp o))
- (curPC))
-
-(def (line)
- "Step one line of the source code.
-
- This will step into functions not over."
- (let ((orig (src)))
- (def (go)
- (step)
- (if (not (equal? orig (src)))
- (curPC)
- (go)))
- (go)))
-
-(def (over)
- "Step one line of source code, going over a function call, not in"
- (let ((f (car (_stk))))
- (line)
- (if (equal? f (car (_stk)))
- (curPC)
- (begin (func)
- (line)))))
-
-(def (asmlist (n 5) (addr (curPC)))
- "Return a list of the next `n` disassembled instructions starting at `addr`.
-
- Each element in the list has the form `(address . instr)` where `instr`
- is the disassembled instruction at the `address`.
-
- Examples: just like `(asm)` but returns a list instead of printing."
- (if (<= n 0)
- ()
- (let ((on-bp (has? bptbl addr)))
- (when on-bp (writecore addr (get bptbl addr)))
- (let ((instr (lsd-das addr))
- (isize (lsd-instsize addr)))
- (when on-bp (writecore addr bpinst))
- (cons (cons addr instr) (asmlist (1- n) (+ addr isize)))))))
-
-(def (asm (n 5) (addr (curPC)))
- "Print the next `n` disassembled instructions at addr.
-
- Examples:
-
- `(asm)` ; print out 5 from current program instruction.
- `(asm 10)` ; print out 10 from current program instruction.
- `(asm 3 (sym-addr 'strecpy))` ; 3 instructions from strecpy"
- (for-each (λ (i) (princ (hex (car i)) "\t" (cdr i) "\n"))
- (asmlist n addr)))
-
-(def (src (addr (curPC)))
- "Return a string of the filename and line number corresponding
- to the instruction address."
- (lsd-fileline addr))
-
-(def (Bsrc (addr (curPC)))
- "Send a plumb message of the filename and line number
- corresponding to the instruction address so that the
- source code can be viewed in your text editor."
- (let ((s (src addr))
- (plumbf (file "/mnt/plumb/send" :write)))
- (io-write plumbf
- (str "plumb\n\n"
- (path-cwd)
- "\ntext\n\n"
- (length s)
- "\n" s))
- (io-close plumbf)))
-
-(def (Bline)
- "Step forward one line of source code and then plumb the
- new line (make a bee line) to your editor."
- (line)
- (Bsrc))
-
-(def (Bover)
- "Same as Bline but with `over`"
- (over)
- (Bsrc))
-
-(def (filepc f (line NIL))
- "Return the instruction address corresponding to a filename
- and line number. It is the inverse of (src addr).
-
- Examples:
-
- #;> (filepc \"/sys/src/cmd/cat.c:5\")
- 2097192
- #;> (filepc \"/sys/src/cmd/cat.c\" 5)
- 2097192
- #;> (src 2097192)
- \"/sys/src/cmd/cat.c:5\""
- (if line
- (lsd-file2pc f line)
- (let ((s (str-split f ":")))
- (when (/= (length s) 2) (error "invalid file"))
- (let ((line (str->num (cadr s))))
- (unless line (error "bad line number"))
- (lsd-file2pc (car s) line)))))
-
-(def (sym-find s)
- "Return a symbol from the attached proc's symbol table or NIL.
- Input is a sym.
-
- Examples:
-
- #;> (sym-find 'strecpy)
- #(symbol \"strecpy\" #\\T 2276784)"
- (let* ((find (λ (tbl k) (and (has? tbl k) (get tbl k)))))
- (or (find (global-text globals) s)
- (find (global-data globals) s))))
-
-(def (sym-addr s)
- "Return the address of a symbol from the attached proc's
- symbol table or NIL. Input is a sym."
- (symbol-addr (sym-find s)))
-
-(add-exit-hook
- (λ (s)
- (when proc-stdin (io-close proc-stdin))
- (detach)
- (lsd-cleanup)
- (for-each (λ (p) (princ "echo kill > /proc/" p "/ctl\n"))
- pids)))
-
-(let* ((proc (cadr *argv*))
- (pid (str->num proc)))
- (if pid (lsd pid) (lsd proc)))
--- /dev/null
+++ b/src/plan9/lsd.sl
@@ -1,0 +1,375 @@
+#!/bin/sl -i
+
+(defstruct reg name type addr size)
+(defstruct symbol name type addr)
+(defstruct global
+ "All the global symbols, separated into text and data symbols.
+
+ The text and data fields are both tables from syms to symbols."
+ text data)
+(defstruct frame
+ "A stack frame. Loc is the enclosing function symbol and instruction
+ address of the frame. Retpc is the return instruction address.
+ Sp is the stack pointer value. Locals are all the local symbols."
+ loc retpc sp locals)
+
+(def coref NIL)
+(def textf NIL)
+(def regsf NIL)
+(def fpregsf NIL)
+(def proc-stdin NIL)
+(def pids NIL)
+(def bptbl (table))
+
+(def (procfile s . flags)
+ (when (< pid 0) (error "no active pid"))
+ (let ((path (str "/proc/" pid "/" s)))
+ (apply file (cons path flags))))
+
+(def (writectl msg)
+ (let ((ctlf (procfile 'ctl :write)))
+ (io-write ctlf msg)
+ (io-close ctlf)))
+
+(def (exited)
+ (when (< pid 0) (error "no active pid"))
+ (princ "process " pid " exited\n")
+ (set! pids (cdr pids))
+ (set! pid (if pids (car pids) -1))
+ (set! bptbl (table))
+ (detach))
+
+(def (readnote)
+ (trycatch
+ (let* ((notef (procfile 'note :read))
+ (note (io-readall notef)))
+ (io-close notef)
+ note)
+ (λ (e) (if (and (eq? (car e) 'io-error)
+ (= (str-find (cadr e) "could not open") 0))
+ (exited)
+ (raise e)))))
+
+(def (start) (writectl "start"))
+(def (startstop) (writectl "startstop") (readnote))
+(def (stop) (writectl "stop") (readnote))
+
+(def (follow addr)
+ "Return a list of the next possible executing instructions."
+ (lsd-follow addr))
+
+(def (io-pread f off rest)
+ (io-seek f off)
+ (apply io-read (cons f rest)))
+
+(def (io-pwrite f off rest)
+ (io-seek f off)
+ (apply io-write (cons f rest))
+ (io-flush f))
+
+(def (readcore addr . rest)
+ (unless coref (error "not attached to proc"))
+ (io-pread coref addr rest))
+
+(def (readtext addr . rest)
+ (unless textf (error "not attached to proc"))
+ (io-pread textf addr rest))
+
+(def (writecore addr . rest)
+ (unless coref (error "not attached to proc"))
+ (io-pwrite coref addr rest))
+
+(def (readreg reg)
+ (unless regsf (error "not attached to proc"))
+ (let ((f (case (reg-type reg)
+ ((:gpreg) regsf)
+ ((:fpreg) fpregsf))))
+ (io-pread f (reg-addr reg) (list (reg-size reg)))))
+
+(def (readsym symbol . rest)
+ (unless coref (error "not attached to proc"))
+ (apply readcore (cons (symbol-addr symbol) rest)))
+
+(def (hex n) (str "0x" (num->str n 16)))
+
+(def (oct n) (str "0" (num->str n 8)))
+
+(def (bpsave a) (readcore a 'byte (length bpinst)))
+
+(let ((bp_init (λ (loc)
+ (when (< pid 0) (error "no running process"))
+ (unless (eq? (status) 'Stopped)
+ (begin (princ "Waiting... " status "\n")
+ (stop)))
+ (cond ((sym? loc) (symbol-addr
+ (get (global-text globals) loc)))
+ ((num? loc) (u64 loc))
+ ((symbol? loc) (symbol-addr loc))
+ ((str? loc) (filepc loc))
+ (else (error "sym|num|symbol|file:line"))))))
+ (set! bpset (λ (loc)
+ (let ((addr (bp_init loc)))
+ (when (has? bptbl addr)
+ (error "breakpoint already set at " loc))
+ (put! bptbl addr (bpsave addr))
+ (writecore addr bpinst))))
+ (set! bpdel (λ (loc)
+ (let ((addr (bp_init loc)))
+ (unless (has? bptbl addr)
+ (error "breakpoint not set at " loc))
+ (writecore addr (get bptbl addr))
+ (del! bptbl addr)))))
+
+(doc-for (bpset loc)
+ "Set a breakpoint.
+
+ The location can be one of the following:
+
+ 1. A sym, in which case the address will be retrieved from
+ the global text symbols of the process,
+ 2. A num which is the address at which to place the break.
+ 3. An LSD symbol in which the case the symbol's address is used.
+ 4. A string of the form \"file:line\" which specifies a line in a
+ file of source code.
+
+ Examples:
+
+ `(bpset 'strcpy)` ; breakpoint on strcpy function.
+ `(bpset (curPC))` ; breakpoint on current instruction.
+ `(bpset \"/sys/src/cmd/cat.c:26\")` ; breakpoint on line 26.")
+
+(doc-for (bpdel loc)
+ "Delete a breakpoint.
+
+ The location can be one of the following:
+
+ 1. A sym, in which case the address will be retrieved from
+ the global text symbols of the process,
+ 2. A num which is the address at which to place the break.
+ 3. An LSD symbol in which the case the symbol's address is used.
+ 4. A string of the form \"file:line\" which specifies a line in a
+ file of source code.
+
+ Examples:
+
+ `(bpdel 'strcpy)` ; remove breakpoint on strcpy function.
+ `(bpdel (curPC))` ; remove breakpoint on current instruction.
+ `(bpdel \"/sys/src/cmd/cat.c:26\")` ; remove breakpoint on line 26.")
+
+(def (detach)
+ (when regsf (io-close regsf))
+ (when fpregsf (io-close fpregsf))
+ (when coref (io-close coref))
+ (when textf (io-close textf))
+ (void))
+
+(def (attach)
+ (detach)
+ (set! regsf (procfile 'regs :read :write))
+ (set! fpregsf (procfile 'fpregs :read :write))
+ (set! coref (procfile 'mem :read :write))
+ (set! textf (procfile 'text :read))
+ (void))
+
+(def (new . args)
+ (let ((v (apply lsd-new args)))
+ (when proc-stdin (io-close proc-stdin))
+ (set! bptbl (table))
+ (set! pid (aref v 0))
+ (set! proc-stdin (aref v 1))
+ (attach)
+ (bpset (car (follow (symbol-addr (get (global-text globals) 'main)))))
+ (startstop)
+ (set! pids (cons pid pids))
+ pid))
+
+(def (lsd a)
+ (let* ((v (lsd-load a))
+ (f (λ (symbol tbl) (put! tbl (sym (symbol-name symbol)) symbol)))
+ (text (foldl f (table) (aref v 3)))
+ (data (foldl f (table) (aref v 4))))
+ (set! pid (aref v 0))
+ (set! registers (aref v 1))
+ (set! bpinst (aref v 2))
+ (set! globals (make-global :text text :data data)))
+ (and (>= pid 0) (attach)))
+
+(def (status)
+ (let* ((sf (procfile 'status))
+ (stats (read-all sf)))
+ (io-close sf)
+ (caddr stats)))
+
+(def tracers (table
+ "386" (λ () (lsd-ctrace (curPC) (readreg SP) (u64 0)))
+ "amd64" (λ () (lsd-ctrace (curPC) (readreg SP) (u64 0)))
+ "arm64" (λ () (lsd-ctrace (curPC) (readreg SP) (readreg R30)))))
+
+(def ctrace (get tracers (os-getenv "objtype")))
+
+(def (_stk)
+ (reverse!
+ (map (λ (f) (frame-locals f (reverse! (frame-locals f))) f)
+ (ctrace))))
+
+(def (curPC) (and (>= pid 0) (readreg PC)))
+
+(def (step (n 1))
+ "Step `n` assembly instructions. Return the next instruction
+ address to be executed or `NIL` if the program has exited."
+ (if (= n 0)
+ (curPC)
+ (let* ((addr (curPC))
+ (on-bp (has? bptbl addr)))
+ (when on-bp (writecore addr (get bptbl addr)))
+ (let* ((f (follow addr))
+ (o (map bpsave f)))
+ (for-each (λ (a) (writecore a bpinst)) f)
+ (startstop)
+ (map writecore f o)
+ (when on-bp (writecore addr bpinst))
+ (step (1- n))))))
+
+(def (cont)
+ "Continue program execution. Return the next instruction
+ address to be executed or `NIL` if the program has exited."
+ (let ((addr (curPC)))
+ (when (has? bptbl addr) (step))
+ (startstop)
+ (curPC)))
+
+(def (func)
+ "Continue program execution until the current function returns."
+ (let* ((bp (frame-retpc (car (_stk))))
+ (o (bpsave bp)))
+ (writecore bp bpinst)
+ (cont)
+ (writecore bp o))
+ (curPC))
+
+(def (line)
+ "Step one line of the source code.
+
+ This will step into functions not over."
+ (let ((orig (src)))
+ (def (go)
+ (step)
+ (if (not (equal? orig (src)))
+ (curPC)
+ (go)))
+ (go)))
+
+(def (over)
+ "Step one line of source code, going over a function call, not in"
+ (let ((f (car (_stk))))
+ (line)
+ (if (equal? f (car (_stk)))
+ (curPC)
+ (begin (func)
+ (line)))))
+
+(def (asmlist (n 5) (addr (curPC)))
+ "Return a list of the next `n` disassembled instructions starting at `addr`.
+
+ Each element in the list has the form `(address . instr)` where `instr`
+ is the disassembled instruction at the `address`.
+
+ Examples: just like `(asm)` but returns a list instead of printing."
+ (if (<= n 0)
+ ()
+ (let ((on-bp (has? bptbl addr)))
+ (when on-bp (writecore addr (get bptbl addr)))
+ (let ((instr (lsd-das addr))
+ (isize (lsd-instsize addr)))
+ (when on-bp (writecore addr bpinst))
+ (cons (cons addr instr) (asmlist (1- n) (+ addr isize)))))))
+
+(def (asm (n 5) (addr (curPC)))
+ "Print the next `n` disassembled instructions at addr.
+
+ Examples:
+
+ `(asm)` ; print out 5 from current program instruction.
+ `(asm 10)` ; print out 10 from current program instruction.
+ `(asm 3 (sym-addr 'strecpy))` ; 3 instructions from strecpy"
+ (for-each (λ (i) (princ (hex (car i)) "\t" (cdr i) "\n"))
+ (asmlist n addr)))
+
+(def (src (addr (curPC)))
+ "Return a string of the filename and line number corresponding
+ to the instruction address."
+ (lsd-fileline addr))
+
+(def (Bsrc (addr (curPC)))
+ "Send a plumb message of the filename and line number
+ corresponding to the instruction address so that the
+ source code can be viewed in your text editor."
+ (let ((s (src addr))
+ (plumbf (file "/mnt/plumb/send" :write)))
+ (io-write plumbf
+ (str "plumb\n\n"
+ (path-cwd)
+ "\ntext\n\n"
+ (length s)
+ "\n" s))
+ (io-close plumbf)))
+
+(def (Bline)
+ "Step forward one line of source code and then plumb the
+ new line (make a bee line) to your editor."
+ (line)
+ (Bsrc))
+
+(def (Bover)
+ "Same as Bline but with `over`"
+ (over)
+ (Bsrc))
+
+(def (filepc f (line NIL))
+ "Return the instruction address corresponding to a filename
+ and line number. It is the inverse of (src addr).
+
+ Examples:
+
+ #;> (filepc \"/sys/src/cmd/cat.c:5\")
+ 2097192
+ #;> (filepc \"/sys/src/cmd/cat.c\" 5)
+ 2097192
+ #;> (src 2097192)
+ \"/sys/src/cmd/cat.c:5\""
+ (if line
+ (lsd-file2pc f line)
+ (let ((s (str-split f ":")))
+ (when (/= (length s) 2) (error "invalid file"))
+ (let ((line (str->num (cadr s))))
+ (unless line (error "bad line number"))
+ (lsd-file2pc (car s) line)))))
+
+(def (sym-find s)
+ "Return a symbol from the attached proc's symbol table or NIL.
+ Input is a sym.
+
+ Examples:
+
+ #;> (sym-find 'strecpy)
+ #(symbol \"strecpy\" #\\T 2276784)"
+ (let* ((find (λ (tbl k) (and (has? tbl k) (get tbl k)))))
+ (or (find (global-text globals) s)
+ (find (global-data globals) s))))
+
+(def (sym-addr s)
+ "Return the address of a symbol from the attached proc's
+ symbol table or NIL. Input is a sym."
+ (symbol-addr (sym-find s)))
+
+(add-exit-hook
+ (λ (s)
+ (when proc-stdin (io-close proc-stdin))
+ (detach)
+ (lsd-cleanup)
+ (for-each (λ (p) (princ "echo kill > /proc/" p "/ctl\n"))
+ pids)))
+
+(let* ((proc (cadr *argv*))
+ (pid (str->num proc)))
+ (if pid (lsd pid) (lsd proc)))
--- a/src/system.lsp
+++ /dev/null
@@ -1,1432 +1,0 @@
-; StreetLISP standard library
-; by Jeff Bezanson (C) 2009
-; Distributed under the BSD License
-
-;;; void
-
-(def (void . rest)
- "Return the constant `#<void>` while ignoring any arguments.
-
- `#<void>` is mainly used when a function has side effects but does not
- produce any meaningful value to return, so even though `T` or `NIL` could
- be returned instead, in case of `#<void>` alone, REPL will not print
- it."
- #.(void))
-
-(def (void? x)
- "Return `T` if `x` is `#<void>`, `NIL` otherwise."
- (eq? x #.(void)))
-
-;;; syntax environment
-
-(unless (bound? '*syntax-environment*)
- (def *syntax-environment* (table)))
-
-(def (set-syntax! s v)
- (put! *syntax-environment* s v))
-
-(def (get-syntax s)
- (get *syntax-environment* s NIL))
-
-(def (separate-doc-from-body body (doc NIL))
- (let {[hd (car body)]- [tl (cdr body)]}
- (cond [(and (not doc) (str? hd) tl)
- (separate-doc-from-body tl (cons hd doc))]
- [(and doc (member hd '(:doc-group :doc-see-also)))
- (separate-doc-from-body (cdr tl) (list* (car tl) hd doc))]
- [else (cons (reverse doc) body)])))
-
-(defmacro (defmacro form . body)
- (let* {[doc+body (separate-doc-from-body body)]- [doc (car doc+body)]
- [body (cdr doc+body)]}
- (when doc
- (sym-set-doc (car form) doc (cdr form)))
- `(void (set-syntax! ',(car form)
- (λ ,(cdr form) ,@body)))))
-
-(defmacro (letrec binds . body)
- `((λ ,(map car binds)
- ,.(map (λ (b) `(set! ,@b)) binds)
- ,@body)
- ,.(map void binds)))
-
-(defmacro (let binds . body)
- (let ((lname NIL))
- (when (sym? binds)
- (set! lname binds)
- (set! binds (car body))
- (set! body (cdr body)))
- (let ((thelambda
- `(λ ,(map (λ (c) (if (cons? c) (car c) c))
- binds)
- ,@body))
- (theargs
- (map (λ (c) (if (cons? c) (cadr c) (void)))
- binds)))
- (cons (if lname
- `(letrec ((,lname ,thelambda)) ,lname)
- thelambda)
- theargs))))
-
-(defmacro (cond . clauses)
- (def (cond-clauses->if lst)
- (if (atom? lst)
- NIL
- (let ((clause (car lst)))
- (if (or (eq? (car clause) 'else)
- (eq? (car clause) T))
- (if (not (cdr clause))
- (car clause)
- (cons 'begin (cdr clause)))
- (if (not (cdr clause))
- ; test by itself
- (list 'or
- (car clause)
- (cond-clauses->if (cdr lst)))
- ; test => expression
- (if (eq? (cadr clause) '=>)
- (if (1arg-lambda? (caddr clause))
- ; test => (λ (x) ...)
- (let ((var (caadr (caddr clause))))
- `(let ((,var ,(car clause)))
- (if ,var
- ,(cons 'begin (cddr (caddr clause)))
- ,(cond-clauses->if (cdr lst)))))
- ; test => proc
- `(let ((b# ,(car clause)))
- (if b#
- (,(caddr clause) b#)
- ,(cond-clauses->if (cdr lst)))))
- (list 'if
- (car clause)
- (cons 'begin (cdr clause))
- (cond-clauses->if (cdr lst)))))))))
- (cond-clauses->if clauses))
-
-;;; props
-
-;; This is implemented in a slightly different fashion as expected:
-;;
-;; *properties* : key → { symbol → value }-;;
-;; The assumption here is that keys will most likely be the same across multiple symbols
-;; so it makes more sense to reduce the number of subtables for the *properties* table.
-(unless (bound? '*properties*)
- (def *properties* (table)))
-
-(def (putprop symbol key val)
- "Associate a property value with a symbol."
- (let ((kt (get *properties* key NIL)))
- (unless kt
- (let ((ta (table)))
- (put! *properties* key ta)
- (set! kt ta)))
- (put! kt symbol val)
- val))
-
-(def (getprop symbol key (def NIL))
- "Get a property value associated with a symbol or `def` if missing."
- (let ((kt (get *properties* key NIL)))
- (or (and kt (get kt symbol def)) def)))
-
-(def (remprop symbol key)
- "Remove a property value associated with a symbol."
- (let ((kt (get *properties* key NIL)))
- (and kt (has? kt symbol) (del! kt symbol))))
-
-;;; documentation
-
-(def (sym-set-doc symbol doc-seq . funvars)
- (let {[doc (if (str? doc-seq)- doc-seq
- (car doc-seq))]}
- (when (and (bound? 'str-join) doc)
- (let* {[lines (str-split doc "\n")]- [hd (car lines)]
- [tl (cdr lines)]
- [snd (any (λ (s) (and (> (length s) 0)
- (= (aref s 0) #\space)
- s))
- tl)]
- [indent (and snd
- (- (length snd)
- (length (str-trim snd " " ""))))]
- [trimmed (and snd
- (map (λ (s) (if (<= indent (length s))
- (str-sub s indent)
- s))
- tl))]
- [final (str-join (cons hd trimmed) "\n")]}
- (putprop symbol '*doc* final)))
- (when (cons? funvars)
- (let* {[existing (getprop symbol '*funvars* NIL)]- ; filter out duplicates
- [to-add (filter (λ (funvar) (not (member funvar existing)))
- funvars)]}
- (putprop symbol '*funvars* (append existing to-add))))
- (void)))
-
-;; chicken and egg - properties defined before sym-set-doc
-(sym-set-doc
- '*properties*
- "All properties of symbols recorded with `putprop` are recorded in this table.")
-
-(def (help-print-header term sigs)
- "Format and print term's signature(s) for `(help term)` output."
- (if sigs
- (for-each (λ (sig) (print (cons term sig))
- (newline))
- sigs)
- (begin (print term)
- (newline)))
- (newline))
-
-(defmacro (help term (:print-header help-print-header))
- "Display documentation for the specified term, if available."
- (let* {[doc (getprop term '*doc*)]- [sigs (getprop term '*funvars* NIL)]}
- (if (or doc sigs)
- `(begin (,print-header ',term ',sigs)
- (when ,doc
- (princ ,doc)
- (newline))
- (void))
- (begin (princ "no help for " term)
- (when (and (sym? term)
- (not (bound? term)))
- (princ " (undefined)"))
- (newline))
- (void))))
-
-;;; standard procedures
-
-(def (member item lst)
- (cond ((equal? (car lst) item) lst)
- (lst (member item (cdr lst)))))
-
-(def (memv item lst)
- (cond ((eqv? (car lst) item) lst)
- (lst (memv item (cdr lst)))))
-
-(def (assoc item lst)
- (cond ((equal? (caar lst) item) (car lst))
- (lst (assoc item (cdr lst)))))
-
-(def (assv item lst)
- (cond ((eqv? (caar lst) item) (car lst))
- (lst (assv item (cdr lst)))))
-
-(def (> a . rest)
- "Return `T` if the arguments are in strictly decreasing order (previous
- one is greater than the next one)."
- (let loop ((a a) (rest rest))
- (or (not rest)
- (and (< (car rest) a)
- (loop (car rest) (cdr rest))))))
-(defmacro (> a . rest)
- `(< ,@(reverse! rest) ,a))
-
-(def (<= a . rest)
- "Return `T` if the arguments are in non-decreasing order (previous
- one is less than or equal to the next one)."
- (let loop ((a a) (rest rest))
- (or (not rest)
- (unless (or (< (car rest) a)
- (nan? a))
- (loop (car rest) (cdr rest))))))
-
-(def (>= a . rest)
- "Return `T` if the arguments are in non-increasing order (previous
- one is greater than or equal to the next one)."
- (let loop ((a a) (rest rest))
- (or (not rest)
- (unless (or (< a (car rest))
- (nan? a))
- (loop (car rest) (cdr rest))))))
-
-(defmacro (/= a . rest)
- "Return `T` if not all arguments are equal. Shorthand for `(not (= …))`."
- `(not (= ,a ,@rest)))
-
-(def (negative? x)
- "Return `T` if `x` is negative."
- (< x 0))
-
-(def (zero? x)
- "Return `T` if `x` is zero."
- (= x 0))
-
-(def (positive? x)
- "Return `T` if `x` is greater than zero."
- (> x 0))
-
-(def (even? x)
- (= (logand x 1) 0))
-
-(def (odd? x)
- (not (even? x)))
-
-(def (identity x)
- "Return `x`."
- x)
-
-(def (1+ n)
- "Equivalent to `(+ n 1)`."
- (+ n 1))
-
-(def (1- n)
- "Equivalent to `(- n 1)`."
- (- n 1))
-
-(def (div x y)
- (+ (div0 x y)
- (or (and (< x 0)
- (or (and (< y 0) 1)
- -1))
- 0)))
-
-(def (mod0 x y)
- (- x (* (div0 x y) y)))
-
-(def (mod x y)
- (- x (* (div x y) y)))
-
-(def (random n)
- (if (int? n)
- (mod (rand) n)
- (* (rand-double) n)))
-
-(def (abs x)
- (if (< x 0)
- (- x)
- x))
-
-(def (max x0 . xs)
- (if xs
- (foldl (λ (a b) (if (< a b) b a))
- x0
- xs)
- x0))
-
-(def (min x0 . xs)
- (if xs
- (foldl (λ (a b) (if (< a b) a b))
- x0
- xs)
- x0))
-
-(def (rune? x)
- (eq? (typeof x) 'rune))
-
-(def (arr? x)
- (or (vec? x)
- (let ((tx (typeof x)))
- (and (cons? tx) (eq? (car tx) 'arr)))))
-
-(def (closure? x)
- (and (fn? x)
- (not (builtin? x))))
-
-(def (caar x) (car (car x)))
-(def (cdar x) (cdr (car x)))
-(def (cddr x) (cdr (cdr x)))
-(def (caaar x) (car (car (car x))))
-(def (caadr x) (car (car (cdr x))))
-(def (cadar x) (car (cdr (car x))))
-(def (caddr x) (car (cdr (cdr x))))
-(def (cdaar x) (cdr (car (car x))))
-(def (cdadr x) (cdr (car (cdr x))))
-(def (cddar x) (cdr (cdr (car x))))
-(def (cdddr x) (cdr (cdr (cdr x))))
-(def (caaaar x) (car (car (car (car x)))))
-(def (caaadr x) (car (car (car (cdr x)))))
-(def (caadar x) (car (car (cdr (car x)))))
-(def (caaddr x) (car (car (cdr (cdr x)))))
-(def (cadaar x) (car (cdr (car (car x)))))
-(def (cadadr x) (car (cdr (car (cdr x)))))
-(def (caddar x) (car (cdr (cdr (car x)))))
-(def (cadddr x) (car (cdr (cdr (cdr x)))))
-(def (cdaaar x) (cdr (car (car (car x)))))
-(def (cdaadr x) (cdr (car (car (cdr x)))))
-(def (cdadar x) (cdr (car (cdr (car x)))))
-(def (cdaddr x) (cdr (car (cdr (cdr x)))))
-(def (cddaar x) (cdr (cdr (car (car x)))))
-(def (cddadr x) (cdr (cdr (car (cdr x)))))
-(def (cdddar x) (cdr (cdr (cdr (car x)))))
-(def (cddddr x) (cdr (cdr (cdr (cdr x)))))
-
-(let ((*values* (list '*values*)))
- (set! values
- (λ vs
- (if (and (cons? vs) (not (cdr vs)))
- (car vs)
- (cons *values* vs))))
- (set! call-with-values
- (λ (producer consumer)
- (let ((res (producer)))
- (if (and (cons? res) (eq? *values* (car res)))
- (apply consumer (cdr res))
- (consumer res))))))
-
-;;; list utilities
-
-(def (every pred lst)
- (or (atom? lst)
- (and (pred (car lst))
- (every pred (cdr lst)))))
-
-(def (any pred lst)
- (and (cons? lst)
- (or (pred (car lst))
- (any pred (cdr lst)))))
-
-(def (list? a)
- (or (not a) (and (cons? a) (list? (cdr a)))))
-
-(def (list-tail lst n)
- (if (<= n 0)
- lst
- (list-tail (cdr lst) (- n 1))))
-
-(def (list-head lst n)
- (and (> n 0)
- (cons (car lst)
- (list-head (cdr lst) (- n 1)))))
-
-(def (list-ref lst n)
- (car (list-tail lst n)))
-
-(def (length= lst n)
- "Perform a bounded length test.
-
- Use this instead of `(= (length lst) n)`, since it avoids unnecessary
- work and always terminates."
- (cond ((< n 0) NIL)
- ((= n 0) (atom? lst))
- ((atom? lst) (= n 0))
- (else (length= (cdr lst) (- n 1)))))
-
-(def (length> lst n)
- (cond ((< n 0) lst)
- ((= n 0) (and (cons? lst) lst))
- ((atom? lst) (< n 0))
- (else (length> (cdr lst) (- n 1)))))
-
-(def (last-pair l)
- (if (atom? (cdr l))
- l
- (last-pair (cdr l))))
-
-(def (lastcdr l)
- (if (atom? l)
- l
- (cdr (last-pair l))))
-
-(def (to-proper l)
- (cond ((not l) l)
- ((atom? l) (list l))
- (else (cons (car l) (to-proper (cdr l))))))
-
-(def (map! f lst)
- (prog1 lst
- (while (cons? lst)
- (set-car! lst (f (car lst)))
- (set! lst (cdr lst)))))
-
-(def (filter pred lst)
- (def (filter- f lst acc)
- (cdr
- (prog1 acc
- (while (cons? lst)
- (when (pred (car lst))
- (set! acc
- (cdr (set-cdr! acc (cons (car lst) NIL)))))
- (set! lst (cdr lst))))))
- (filter- pred lst (list NIL)))
-
-(def (partition pred lst)
- (def (partition- pred lst yes no)
- (let ((vals
- (prog1
- (cons yes no)
- (while (cons? lst)
- (if (pred (car lst))
- (set! yes (cdr (set-cdr! yes (cons (car lst) NIL))))
- (set! no (cdr (set-cdr! no (cons (car lst) NIL)))))
- (set! lst (cdr lst))))))
- (values (cdr (car vals)) (cdr (cdr vals)))))
- (partition- pred lst (list NIL) (list NIL)))
-
-(def (count f l)
- (def (count- f l n)
- (if (not l)
- n
- (count- f (cdr l) (if (f (car l))
- (+ n 1)
- n))))
- (count- f l 0))
-
-(def (nestlist f zero n)
- (and (> n 0)
- (cons zero (nestlist f (f zero) (- n 1)))))
-
-(def (foldr f zero lst)
- (if (not lst)
- zero
- (f (car lst) (foldr f zero (cdr lst)))))
-
-(def (foldl f zero lst)
- (if (not lst)
- zero
- (foldl f (f (car lst) zero) (cdr lst))))
-
-(def (reverse- zero lst)
- (if (not lst)
- zero
- (reverse- (cons (car lst) zero) (cdr lst))))
-
-(def (reverse lst)
- (reverse- NIL lst))
-
-(def (reverse!- prev l)
- (while (cons? l)
- (set! l (prog1 (cdr l)
- (set-cdr! l (prog1 prev
- (set! prev l))))))
- prev)
-
-(def (reverse! l)
- (reverse!- NIL l))
-
-(def (copy-tree l)
- (if (atom? l)
- l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
-(def (delete-duplicates lst)
- (if (length> lst 20)
- (let ((ta (table)))
- (let loop ((l lst) (acc NIL))
- (if (atom? l)
- (reverse! acc)
- (if (has? ta (car l))
- (loop (cdr l) acc)
- (begin
- (put! ta (car l) T)
- (loop (cdr l) (cons (car l) acc)))))))
- (if (atom? lst)
- lst
- (let ((elt (car lst))
- (tail (cdr lst)))
- (if (member elt tail)
- (delete-duplicates tail)
- (cons elt
- (delete-duplicates tail)))))))
-
-; you are not expected to understand this -- spew
-
-(def (zip-with f . lst)
- (apply map f lst))
-
-(def (zip . lst)
- (apply map list lst))
-
-;;; backquote
-
-(def (revappend l1 l2)
- (reverse- l2 l1))
-
-(def (nreconc l1 l2)
- (reverse!- l2 l1))
-
-(def (self-evaluating? x)
- (and (not (gensym? x))
- (or (and (atom? x)
- (not (sym? x)))
- (and (const? x)
- (sym? x)
- (eq? x (top-level-value x))))))
-
-(defmacro (quasiquote x) (bq-process x 0))
-
-(def (splice-form? x)
- (or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
- (eq? (car x) 'unquote-nsplicing)
- (and (eq? (car x) 'unquote)
- (length> x 2))))
- (eq? x 'unquote)))
-
-;; bracket without splicing
-(def (bq-bracket1 x d)
- (if (and (cons? x) (eq? (car x) 'unquote))
- (if (= d 0)
- (cadr x)
- (list cons ''unquote
- (bq-process (cdr x) (- d 1))))
- (bq-process x d)))
-
-(def (bq-bracket x d)
- (cond ((atom? x) (list list (bq-process x d)))
- ((eq? (car x) 'unquote)
- (if (= d 0)
- (cons list (cdr x))
- (list list (list cons ''unquote
- (bq-process (cdr x) (- d 1))))))
- ((eq? (car x) 'unquote-splicing)
- (if (= d 0)
- (list 'copy-list (cadr x))
- (list list (list list ''unquote-splicing
- (bq-process (cadr x) (- d 1))))))
- ((eq? (car x) 'unquote-nsplicing)
- (if (= d 0)
- (cadr x)
- (list list (list list ''unquote-nsplicing
- (bq-process (cadr x) (- d 1))))))
- (else (list list (bq-process x d)))))
-
-(def (bq-process x d)
- (cond ((sym? x) (list 'quote x))
- ((vec? x)
- (let ((body (bq-process (vec->list x) d)))
- (if (eq? (car body) list)
- (cons vec (cdr body))
- (list apply vec body))))
- ((atom? x) x)
- ((eq? (car x) 'quasiquote)
- (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
- ((eq? (car x) 'unquote)
- (if (and (= d 0) (length= x 2))
- (cadr x)
- (list cons ''unquote (bq-process (cdr x) (- d 1)))))
- ((not (any splice-form? x))
- (let ((lc (lastcdr x))
- (forms (map (λ (x) (bq-bracket1 x d)) x)))
- (if (not lc)
- (cons list forms)
- (if (not (cdr forms))
- (list cons (car forms) (bq-process lc d))
- (nconc (cons list* forms) (list (bq-process lc d)))))))
- (else
- (let loop ((p x) (q NIL))
- (cond ((not p) ;; proper list
- (cons 'nconc (reverse! q)))
- ((cons? p)
- (cond ((eq? (car p) 'unquote)
- ;; (... . ,x)
- (cons 'nconc
- (nreconc q
- (if (= d 0)
- (cdr p)
- (list (list list ''unquote)
- (bq-process (cdr p)
- (- d 1)))))))
- (else
- (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
- (else
- ;; (... . x)
- (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
-
-;;; standard macros
-
-(def (quote-value v)
- (if (self-evaluating? v)
- v
- (list 'quote v)))
-
-(defmacro (let* binds . body)
- (if (atom? binds)
- `((λ () ,@body))
- `((λ (,(caar binds))
- ,@(if (cons? (cdr binds))
- `((let* ,(cdr binds) ,@body))
- body))
- ,(cadar binds))))
-
-(defmacro (when c . body)
- (list 'if c (cons 'begin body) NIL))
-
-(defmacro (unless c . body)
- (list 'if c NIL (cons 'begin body)))
-
-(defmacro (case key . clauses)
- (def (vals->cond key v)
- (cond ((eq? v 'else) 'else)
- ((not v) NIL)
- ((sym? v) `(eq? ,key ,(quote-value v)))
- ((atom? v) `(eqv? ,key ,(quote-value v)))
- ((not (cdr v)) `(eqv? ,key ,(quote-value (car v))))
- ((every sym? v)
- `(memq ,key ',v))
- (else `(memv ,key ',v))))
- (let ((g (gensym)))
- `(let ((,g ,key))
- (cond ,.(map (λ (clause)
- (cons (vals->cond g (car clause))
- (cdr clause)))
- clauses)))))
-
-(defmacro (do vars test-spec . commands)
- (let ((test-expr (car test-spec))
- (vars (map car vars))
- (inits (map cadr vars))
- (steps (map (λ (x)
- (if (cons? (cddr x))
- (caddr x)
- (car x)))
- vars)))
- `(letrec ((loop# (λ ,vars
- (if ,test-expr
- (begin
- ,@(cdr test-spec))
- (begin
- ,@commands
- (loop# ,.steps))))))
- (loop# ,.inits))))
-
-; SRFI 8
-(defmacro (receive formals expr . body)
- `(call-with-values (λ () ,expr)
- (λ ,formals ,@body)))
-
-(defmacro (dotimes var . body)
- (let ((v (car var))
- (cnt (cadr var)))
- `(for 0 (- ,cnt 1)
- (λ (,v) ,@body))))
-
-(def (map-int f n)
- (and (> n 0)
- (let ((first (cons (f 0) NIL))
- (acc NIL))
- (set! acc first)
- (for 1 (1- n)
- (λ (i) (set-cdr! acc (cons (f i) NIL))
- (set! acc (cdr acc))))
- first)))
-
-(def (iota n)
- (map-int identity n))
-
-(defmacro (with-bindings binds . body)
- (let ((vars (map car binds))
- (vals (map cadr binds))
- (olds (map (λ (x) (gensym)) binds)))
- `(let ,(map list olds vars)
- ,@(map (λ (v val) `(set! ,v ,val)) vars vals)
- (unwind-protect
- (begin ,@body)
- (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
-
-;;; exceptions
-
-(def (error . args)
- (raise (cons 'error args)))
-
-(defmacro (throw tag value)
- `(raise (list 'thrown-value ,tag ,value)))
-
-(defmacro (catch tag expr)
- `(trycatch ,expr
- (λ (e#) (if (and (cons? e#)
- (eq? (car e#) 'thrown-value)
- (eq? (cadr e#) ,tag))
- (caddr e#)
- (raise e#)))))
-
-(defmacro (unwind-protect expr finally)
- `(let ((thk# (λ () ,finally)))
- (prog1 (trycatch ,expr
- (λ (e#) (thk#) (raise e#)))
- (thk#))))
-
-;;; debugging utilities
-
-(defmacro (assert expr)
- `(if ,expr T (raise '(assert-failed ,expr))))
-
-(def traced?
- (let ((sample-traced-lambda (λ args (write (cons 'x args))
- (newline)
- (apply #.apply args))))
- (λ (f)
- (and (closure? f)
- (equal? (fn-code f)
- (fn-code sample-traced-lambda))))))
-
-(def (trace symbol)
- (let ((func (top-level-value symbol)))
- (when (not (traced? func))
- (set-top-level-value! symbol
- (eval
- `(λ args#
- (write (cons ',symbol args#))
- (newline)
- (apply ',func args#))))))
- (void))
-
-(def (untrace symbol)
- (let ((func (top-level-value symbol)))
- (when (traced? func)
- (set-top-level-value! symbol
- (aref (fn-vals func) 3))))
- (void))
-
-(defmacro (time expr)
- `(let ((t0# (time-now)))
- (prog1
- ,expr
- (princ "Elapsed time: " (- (time-now) t0#) " seconds" *linefeed*))))
-
-;;; text I/O
-
-(def (print . args)
- (for-each write args))
-
-(def (princ . args)
- (with-bindings ((*print-readably* NIL))
- (for-each write args)))
-
-(def (newline (io *io-out*))
- (io-write io *linefeed*)
- (void))
-
-(def (io-readline s) (io-readuntil s #\linefeed))
-
-; call f on an io until the io runs out of data
-(def (read-all-of f s)
- (let loop ((lines NIL)
- (curr (f s)))
- (if (io-eof? s)
- (reverse! lines)
- (loop (cons curr lines) (f s)))))
-
-(def (io-readlines s)
- (read-all-of io-readline s))
-
-(def (read-all s)
- (read-all-of read s))
-
-(def (io-readall s)
- (let ((b (buffer)))
- (io-copy b s)
- (io->str b)))
-
-(defmacro (with-output-to io . body)
- `(with-bindings ((*io-out* ,io))
- ,@body))
-
-(defmacro (with-input-from io . body)
- `(with-bindings ((*io-in* ,io))
- ,@body))
-
-;;; vector functions
-
-(def (list->vec l)
- (apply vec l))
-
-(def (vec->list v)
- (let ((n (length v))
- (l NIL))
- (for 1 n
- (λ (i)
- (set! l (cons (aref v (- n i)) l))))
- l))
-
-(def (vec-map f v)
- (let* ((n (length v))
- (nv (vec-alloc n)))
- (for 0 (- n 1)
- (λ (i)
- (aset! nv i (f (aref v i)))))
- nv))
-
-;;; table functions
-
-(def (table-pairs ta)
- (table-foldl (λ (k v z) (cons (cons k v) z))
- NIL ta))
-(def (table-keys ta)
- (table-foldl (λ (k v z) (cons k z))
- NIL ta))
-(def (table-values ta)
- (table-foldl (λ (k v z) (cons v z))
- NIL ta))
-(def (table-clone ta)
- (let ((nt (table)))
- (table-foldl (λ (k v z) (put! nt k v))
- NIL ta)
- nt))
-(def (table-invert ta)
- (let ((nt (table)))
- (table-foldl (λ (k v z) (put! nt v k))
- NIL ta)
- nt))
-
-;;; string functions
-
-(def (str-tail s n)
- (str-sub s n))
-
-(def (str-trim s at-start at-end)
- (def (trim-start s runes i L)
- (if (and (< i L) (str-find runes (str-rune s i)))
- (trim-start s runes (1+ i) L)
- i))
- (def (trim-end s runes i)
- (if (and (> i 0) (str-find runes (str-rune s (1- i))))
- (trim-end s runes (1- i))
- i))
- (let ((L (str-length s)))
- (str-sub s
- (trim-start s at-start 0 L)
- (trim-end s at-end L))))
-
-(def (str-map f s)
- (let ((b (buffer))
- (n (str-length s)))
- (let ((i 0))
- (while (< i n)
- (io-putc b (f (str-rune s i)))
- (set! i (1+ i))))
- (io->str b)))
-
-(def (str-rep s k)
- (cond ((< k 4)
- (cond ((<= k 0) "")
- ((= k 1) (str s))
- ((= k 2) (str s s))
- (else (str s s s))))
- ((odd? k) (str s (str-rep s (- k 1))))
- (else (str-rep (str s s) (/ k 2)))))
-
-(def (str-lpad s n c)
- (str (str-rep c (- n (str-length s))) s))
-
-(def (str-rpad s n c)
- (str s (str-rep c (- n (str-length s)))))
-
-(def (print-to-str . args)
- (let ((b (buffer)))
- (for-each (λ (a) (write a b)) args)
- (io->str b)))
-
-(def (str-join strlist sep)
- (if (not strlist)
- ""
- (let ((b (buffer)))
- (io-write b (car strlist))
- (for-each (λ (s) (io-write b sep)
- (io-write b s))
- (cdr strlist))
- (io->str b))))
-
-;;; structs
-
-(defmacro (defstruct name (:type vec)
- (:named T)
- (:constructor T)
- (:conc-name NIL)
- (:predicate NIL)
- . slots)
- "Defines a structure type with a specific name and slots.
-
- The default underlying type is a \"named\" vector (`:type vec`),
- where the first element is the name of the structure's type, the
- rest are the slot values. If the name as the first element isn't
- required, `:named NIL` should be used. A list can be used instead
- of a vector by adding `:type list` option.
-
- An example of a default constructor signature, based on structure
- definition:
-
- (defstruct blah a b c) →
- (make-blah (:a NIL) (:b NIL) (:c NIL))
-
- It can be customized in several ways. For example:
-
- ; disable the constructor altogether
- (defstruct blah :constructor NIL a b c)
- ; only change its name
- (defstruct blah :constructor blargh a b c)
- ; rename AND avoid using keywords
- (defstruct blah :constructor (blah a b c) a b c)
-
- The option `:conc-name` specifies the slot accessor prefix, which
- defaults to `name-`.
-
- Default predicate name (`name?`) can be changed:
-
- ; use \"blargh?\" instead of \"blah?\"
- (defstruct blah :predicate blargh? a b c)"
- (def (slot-opts slot)
- ; check whether slot options, if any, are valid
- (let ((opts (cddr slot)))
- (for-each (λ (opt) (unless (member opt '(:read-only))
- (error (str "invalid option in slot " (car slot)
- " of struct " name
- ": " opt))))
- opts)
- opts))
- (def (tokw slots)
- ; transform args list to keyworded variant.
- ; eg: (a (b 1) (c :read-only)) → ((:a NIL) (:b 1) (:c NIL :read-only))
- (map! (λ (slot) (let* {[name-cons (and (cons? slot)- (car slot))]
- [name (or name-cons slot)]
- [tail (or (and name-cons
- (cdr slot))
- (list NIL))]}
- (when (or (not (sym? name))
- (keyword? name))
- (error "invalid slot name: " name))
- (list* (sym #\: name)
- (if (keyword? (car tail))
- (cons NIL tail)
- tail))))
- slots))
- (let* {; first element in slots may be the doc string- [doc (and (str? (car slots))
- (car slots))]
- ; if it is, rid of it
- [slots (or (and doc (cdr slots))
- slots)]
- [num-slots (length slots)]
- ; list of slot names
- [slots-car (map (λ (f) (if (cons? f) (car f) f))
- slots)]
- ; slots, but with default values added (if not set)
- ; and keywords for names
- [slots-kw (tokw slots)]
- ; struct's underlying type's predicate (either vec? or list?)
- [type? (sym type #\?)]
- ; struct's predicate name
- [is? (or predicate
- (sym name #\?))]
- ; constructor name and arguments
- [constructor
- (and constructor ; NIL means none to make at all
- (or (and (atom? constructor) ; a single argument
- (cons (or (and (eq? constructor T) ; T means the defaults
- (sym "make-" name))
- constructor) ; else a custom name
- slots-kw))
- constructor))] ; anything else means custom name and args
- ; should the struct name appear as the first element?
- [named (and named (list name))]
- ; accessor prefix
- [access (or conc-name
- (str name "-"))]}
- `(begin
- ; predicate
- (def (,is? s)
- (and [,type? s]
- [or (not ',named) (eq? (aref s 0) ',name)]
- [= (length s) ,(+ (length named) num-slots)]))
- ; documentation string
- (when ,doc
- (sym-set-doc ',name ,doc))
- ; constructor
- ,(when constructor `(def ,constructor
- (,type ',@named ,@slots-car)))
- ; accessor per slot
- ,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))]- [fld (list-ref slots-car i)]
- [fun (sym access fld)]}
- `(def (,fun s (v #.(void)))
- (assert (,is? s))
- (if (void? v)
- (aref s ,[+ (length named) i])
- ,(if (member :read-only opts)
- `(error (str "slot "
- ',fld
- " in struct "
- ',name
- " is :read-only"))
- `(aset! s ,[+ (length named) i] v))))])
- num-slots))))
-
-(doc-for (defstruct name
- doc
- options…
- (slot-1 DEFAULT)
- slot-2
- (slot-3 :read-only)))
-
-;;; toplevel
-
-(def (macrocall? e)
- (and (sym? (car e))
- (get-syntax (car e))))
-
-(def (macroexpand-1 e)
- (if (atom? e)
- e
- (let ((f (macrocall? e)))
- (if f
- (apply f (cdr e))
- e))))
-
-(def (macroexpand e)
- ; symbol resolves to toplevel; i.e. has no shadowing definition
- (def (top? s env) (not (or (bound? s) (assq s env))))
-
- (def (splice-begin body)
- (cond ((atom? body) body)
- ((equal? body '((begin)))
- body)
- ((and (cons? (car body))
- (eq? (caar body) 'begin))
- (append (splice-begin (cdar body)) (splice-begin (cdr body))))
- (else
- (cons (car body) (splice-begin (cdr body))))))
-
- (def *expanded* (list '*expanded*))
-
- (def (expand-body body env)
- (if (atom? body)
- body
- (let* ((body (if (top? 'begin env)
- (splice-begin body)
- body))
- (def? (top? 'def env))
- (dvars (and def? (get-defined-vars body)))
- (env (nconc (map list dvars) env)))
- (if (not def?)
- (map (λ (x) (expand-in x env)) body)
- (let* ((ex-nondefs ; expand non-definitions
- (let loop ((body body))
- (cond ((atom? body) body)
- ((and (cons? (car body))
- (eq? 'def (caar body)))
- (cons (car body) (loop (cdr body))))
- (else
- (let ((form (expand-in (car body) env)))
- (set! env (nconc
- (map list (get-defined-vars form))
- env))
- (cons
- (cons *expanded* form)
- (loop (cdr body))))))))
- (body ex-nondefs))
- (while (cons? body) ; now expand deferred definitions
- (if (not (eq? *expanded* (caar body)))
- (set-car! body (expand-in (car body) env))
- (set-car! body (cdar body)))
- (set! body (cdr body)))
- ex-nondefs)))))
-
- (def (expand-lambda-list l env)
- (if (atom? l)
- l
- (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
- (list (caar l) (expand-in (cadar l) env))
- (car l))
- (expand-lambda-list (cdr l) env))))
-
- (def (l-vars l)
- (cond ((atom? l) (list l))
- ((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
- (else (cons (car l) (l-vars (cdr l))))))
-
- (def (expand-lambda e env)
- (let ((formals (cadr e))
- (name (lastcdr e))
- (body (cddr e))
- (vars (l-vars (cadr e))))
- (let ((env (nconc (map list vars) env)))
- `(λ ,(expand-lambda-list formals env)
- ,.(expand-body body env)
- . ,name))))
-
- (def (expand-define e env)
- (if (or (not (cdr e)) (atom? (cadr e)))
- (if (not (cddr e))
- e
- (let* ((name (cadr e))
- (doc+body (separate-doc-from-body (cddr e)))
- (doc (car doc+body))
- (body (cdr doc+body)))
- (when doc
- (sym-set-doc name doc))
- `(def ,name ,(expand-in (car body) env))))
- (let* ((formals (cdadr e))
- (name (caadr e))
- (doc+body (separate-doc-from-body (cddr e)))
- (doc (car doc+body))
- (body (cdr doc+body))
- (vars (l-vars formals))
- (menv (nconc (map list vars) env)))
- (when doc
- (sym-set-doc name doc formals))
- `(def ,(cons name (expand-lambda-list formals menv))
- ,.(expand-body body menv)))))
-
- (def (expand-let-syntax e env)
- (let ((binds (cadr e)))
- (cons 'begin
- (expand-body (cddr e)
- (nconc
- (map (λ (bind)
- (list (car bind)
- ((compile-thunk
- (expand-in (cadr bind) env)))
- env))
- binds)
- env)))))
-
- ; given let-syntax definition environment (menv) and environment
- ; at the point of the macro use (lenv), return the environment to
- ; expand the macro use in. TODO
- (def (local-expansion-env menv lenv) menv)
-
- (def (expand-in e env)
- (if (atom? e)
- e
- (let* ((head (car e))
- (bnd (assq head env))
- (default (λ ()
- (let loop ((e e))
- (if (atom? e)
- e
- (cons (if (atom? (car e))
- (car e)
- (expand-in (car e) env))
- (loop (cdr e))))))))
- (cond ((and bnd (cons? (cdr bnd))) ; local macro
- (expand-in (apply (cadr bnd) (cdr e))
- (local-expansion-env (caddr bnd) env)))
- ((macrocall? e) => (λ (f)
- (expand-in (apply f (cdr e)) env)))
- ((or bnd ; bound lexical or toplevel var
- (not (sym? head))
- (bound? head))
- (default))
- ((eq? head 'quote) e)
- ((eq? head 'λ) (expand-lambda e env))
- ((eq? head 'lambda) (expand-lambda e env))
- ((eq? head 'def) (expand-define e env))
- ((eq? head 'let-syntax) (expand-let-syntax e env))
- (else (default))))))
- (expand-in e NIL))
-
-(def (eval x)
- ((compile-thunk (macroexpand x))))
-
-(def (load-process x)
- (eval x))
-
-(def (load filename)
- (let ((F (file filename :read)))
- (trycatch
- (let next (prev E v)
- (if (not (io-eof? F))
- (next (read F)
- prev
- (begin (load-process E) (void)))
- (begin (io-close F)
- ; evaluate last form in almost-tail position
- (void (load-process E)))))
- (λ (e)
- (io-close F)
- (raise `(load-error ,filename ,e))))))
-
-(def (repl)
- (def (prompt)
- (*prompt*)
- (io-flush *io-out*)
- (let ((v (trycatch (read)
- (λ (e) (io-discardbuffer *io-in*)
- (raise e)))))
- (and (not (io-eof? *io-in*))
- (let ((V (load-process v)))
- (unless (void? V) (print V) (newline))
- (void (set! that V))))))
- (def (reploop)
- (when (trycatch (prompt)
- (λ (e)
- (top-level-exception-handler e)
- T))
- (reploop)))
- (reploop)
- (newline))
-
-(def (top-level-exception-handler e)
- (with-output-to *stderr*
- (print-exception e)
- (print-stack-trace (stacktrace))))
-
-(def (print-stack-trace st)
- (def (find-in-f f tgt path)
- (let ((path (cons (fn-name f) path)))
- (if (eq? (fn-code f) (fn-code tgt))
- (throw 'ffound path)
- (let ((v (fn-vals f)))
- (for 0 (1- (length v))
- (λ (i) (when (closure? (aref v i))
- (find-in-f (aref v i) tgt path))))))))
- (def (fname f e)
- (let ((p (catch 'ffound
- (begin
- (for-each (λ (topfun)
- (find-in-f topfun f NIL))
- e)
- NIL))))
- (if p
- (str-join (map str (reverse! p)) "/")
- "λ")))
- (let ((st (reverse! (if (length> st 3)
- (list-tail st (if *interactive* 5 4))
- st)))
- (e (filter closure? (map (λ (s) (and (bound? s)
- (top-level-value s)))
- (environment))))
- (n 0))
- (for-each
- (λ (f)
- (princ "(" (fname (aref f 1) e))- (for-each (λ (p) (princ " ") (print p))
- (cdr (cdr (vec->list f))))
- (princ ")" *linefeed*)
- (when (= n 0)
- (fn-disasm (aref f 1) (aref f 0)))
- (set! n (+ n 1)))
- st)))
-
-(def (print-exception e)
- (cond ((and (cons? e)
- (eq? (car e) 'type-error)
- (length= e 3))
- (princ "type error: expected " (cadr e) ", got " (typeof (caddr e)) ": ")
- (print (caddr e)))
-
- ((and (cons? e)
- (eq? (car e) 'bounds-error)
- (length= e 3))
- (princ "index " (caddr e) " out of bounds for ")
- (print (cadr e)))
-
- ((and (cons? e)
- (eq? (car e) 'unbound-error)
- (length= e 2))
- (princ "eval: variable " (cadr e) " has no value"))
-
- ((and (cons? e)
- (eq? (car e) 'error))
- (princ "error: ")
- (apply princ (cdr e)))
-
- ((and (cons? e)
- (eq? (car e) 'load-error))
- (print-exception (caddr e))
- (princ "in file " (cadr e)))
-
- ((and (list? e)
- (length= e 2))
- (print (car e))
- (princ ": ")
- (let ((msg (cadr e)))
- ((if (or (str? msg) (sym? msg))
- princ
- print)
- msg)))
-
- (else (princ "*** Unhandled exception: ")
- (print e)))
-
- (princ *linefeed*))
-
-(def (make-system-image fname)
- (def (sort l)
- (if (or (not l) (not (cdr l)))
- l
- (let ((piv (car l)))
- (receive (less grtr)
- (partition (λ (x) (< x piv)) (cdr l))
- (nconc (sort less)
- (list piv)
- (sort grtr))))))
- (let ((f (file fname :write :create :truncate))
- (excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
- *print-pretty* *print-width* *print-readably*
- *print-level* *print-length* *os-name* *interactive*
- *prompt* *os-version*)))
- (with-bindings ((*print-pretty* T)
- (*print-readably* T))
- (let* ((syms
- (filter (λ (s)
- (and (bound? s)
- (not (const? s))
- (or (not (builtin? (top-level-value s)))
- (not (equal? (str s) ; alias of builtin
- (str (top-level-value s)))))
- (not (memq s excludes))
- (not (io? (top-level-value s)))))
- (sort (environment))))
- (data (apply nconc (map list syms (map top-level-value syms)))))
- (write data f)
- (io-write f *linefeed*))
- (io-close f))))
-
-; initialize globals that need to be set at load time
-(def (__init_globals)
- (let ((defprompt (if (equal? *os-name* "macos")
- (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
- (λ () (princ "#;> ")))))
- (set! *prompt*
- "Function called by REPL to signal the user input is required.
-
- Default function prints `#;> `."
- defprompt))
- (set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
- (set! *linefeed* "\n")
- (set! *exit-hooks* NIL)
- (set! *io-out* *stdout*)
- (set! *io-in* *stdin*)
- (set! *io-err* *stderr*))
-
-(def (__script fname)
- (trycatch (load fname)
- (λ (e) (top-level-exception-handler e)
- (exit (str e)))))
-
-(def (__rcscript)
- (let* ((homevar (case *os-name*
- (("unknown") NIL)- (("plan9") "home")- (("macos") (princ "\x1b]0;StreetLISP v0.999\007") NIL)- (else "HOME")))
- (home (and homevar (os-getenv homevar)))
- (rcpath (case *os-name*
- (("plan9") "lib/slrc")- (else ".slrc")))
- (fname (and home (str home *directory-separator* rcpath))))
- (and fname (path-exists? fname) (load fname))))
-
-(def (__start argv interactive)
- (__init_globals)
- (set! *argv* argv)
- (set! *interactive* interactive)
- (if (cons? (cdr argv))
- (begin (set! *argv* (cdr argv))
- (__script (cadr argv)))
- (set! *interactive* T))
- (when *interactive*
- (__rcscript)
- (repl))
- (exit))
-
-(def (add-exit-hook fun)
- "Puts an one-argument function on top of the list of exit hooks.
-
- On shutdown each exit hook is called with the exit status as a single
- argument, which is (usually) `NIL` on success and a string describing
- an error otherwise."
- (set! *exit-hooks* (cons fun *exit-hooks*))
- (void))
-
-(def (__finish status)
- "A function called right before exit by the VM."
- (for-each (λ (f) (f status)) *exit-hooks*))
--- /dev/null
+++ b/src/system.sl
@@ -1,0 +1,1432 @@
+; StreetLISP standard library
+; by Jeff Bezanson (C) 2009
+; Distributed under the BSD License
+
+;;; void
+
+(def (void . rest)
+ "Return the constant `#<void>` while ignoring any arguments.
+
+ `#<void>` is mainly used when a function has side effects but does not
+ produce any meaningful value to return, so even though `T` or `NIL` could
+ be returned instead, in case of `#<void>` alone, REPL will not print
+ it."
+ #.(void))
+
+(def (void? x)
+ "Return `T` if `x` is `#<void>`, `NIL` otherwise."
+ (eq? x #.(void)))
+
+;;; syntax environment
+
+(unless (bound? '*syntax-environment*)
+ (def *syntax-environment* (table)))
+
+(def (set-syntax! s v)
+ (put! *syntax-environment* s v))
+
+(def (get-syntax s)
+ (get *syntax-environment* s NIL))
+
+(def (separate-doc-from-body body (doc NIL))
+ (let {[hd (car body)]+ [tl (cdr body)]}
+ (cond [(and (not doc) (str? hd) tl)
+ (separate-doc-from-body tl (cons hd doc))]
+ [(and doc (member hd '(:doc-group :doc-see-also)))
+ (separate-doc-from-body (cdr tl) (list* (car tl) hd doc))]
+ [else (cons (reverse doc) body)])))
+
+(defmacro (defmacro form . body)
+ (let* {[doc+body (separate-doc-from-body body)]+ [doc (car doc+body)]
+ [body (cdr doc+body)]}
+ (when doc
+ (sym-set-doc (car form) doc (cdr form)))
+ `(void (set-syntax! ',(car form)
+ (λ ,(cdr form) ,@body)))))
+
+(defmacro (letrec binds . body)
+ `((λ ,(map car binds)
+ ,.(map (λ (b) `(set! ,@b)) binds)
+ ,@body)
+ ,.(map void binds)))
+
+(defmacro (let binds . body)
+ (let ((lname NIL))
+ (when (sym? binds)
+ (set! lname binds)
+ (set! binds (car body))
+ (set! body (cdr body)))
+ (let ((thelambda
+ `(λ ,(map (λ (c) (if (cons? c) (car c) c))
+ binds)
+ ,@body))
+ (theargs
+ (map (λ (c) (if (cons? c) (cadr c) (void)))
+ binds)))
+ (cons (if lname
+ `(letrec ((,lname ,thelambda)) ,lname)
+ thelambda)
+ theargs))))
+
+(defmacro (cond . clauses)
+ (def (cond-clauses->if lst)
+ (if (atom? lst)
+ NIL
+ (let ((clause (car lst)))
+ (if (or (eq? (car clause) 'else)
+ (eq? (car clause) T))
+ (if (not (cdr clause))
+ (car clause)
+ (cons 'begin (cdr clause)))
+ (if (not (cdr clause))
+ ; test by itself
+ (list 'or
+ (car clause)
+ (cond-clauses->if (cdr lst)))
+ ; test => expression
+ (if (eq? (cadr clause) '=>)
+ (if (1arg-lambda? (caddr clause))
+ ; test => (λ (x) ...)
+ (let ((var (caadr (caddr clause))))
+ `(let ((,var ,(car clause)))
+ (if ,var
+ ,(cons 'begin (cddr (caddr clause)))
+ ,(cond-clauses->if (cdr lst)))))
+ ; test => proc
+ `(let ((b# ,(car clause)))
+ (if b#
+ (,(caddr clause) b#)
+ ,(cond-clauses->if (cdr lst)))))
+ (list 'if
+ (car clause)
+ (cons 'begin (cdr clause))
+ (cond-clauses->if (cdr lst)))))))))
+ (cond-clauses->if clauses))
+
+;;; props
+
+;; This is implemented in a slightly different fashion as expected:
+;;
+;; *properties* : key → { symbol → value }+;;
+;; The assumption here is that keys will most likely be the same across multiple symbols
+;; so it makes more sense to reduce the number of subtables for the *properties* table.
+(unless (bound? '*properties*)
+ (def *properties* (table)))
+
+(def (putprop symbol key val)
+ "Associate a property value with a symbol."
+ (let ((kt (get *properties* key NIL)))
+ (unless kt
+ (let ((ta (table)))
+ (put! *properties* key ta)
+ (set! kt ta)))
+ (put! kt symbol val)
+ val))
+
+(def (getprop symbol key (def NIL))
+ "Get a property value associated with a symbol or `def` if missing."
+ (let ((kt (get *properties* key NIL)))
+ (or (and kt (get kt symbol def)) def)))
+
+(def (remprop symbol key)
+ "Remove a property value associated with a symbol."
+ (let ((kt (get *properties* key NIL)))
+ (and kt (has? kt symbol) (del! kt symbol))))
+
+;;; documentation
+
+(def (sym-set-doc symbol doc-seq . funvars)
+ (let {[doc (if (str? doc-seq)+ doc-seq
+ (car doc-seq))]}
+ (when (and (bound? 'str-join) doc)
+ (let* {[lines (str-split doc "\n")]+ [hd (car lines)]
+ [tl (cdr lines)]
+ [snd (any (λ (s) (and (> (length s) 0)
+ (= (aref s 0) #\space)
+ s))
+ tl)]
+ [indent (and snd
+ (- (length snd)
+ (length (str-trim snd " " ""))))]
+ [trimmed (and snd
+ (map (λ (s) (if (<= indent (length s))
+ (str-sub s indent)
+ s))
+ tl))]
+ [final (str-join (cons hd trimmed) "\n")]}
+ (putprop symbol '*doc* final)))
+ (when (cons? funvars)
+ (let* {[existing (getprop symbol '*funvars* NIL)]+ ; filter out duplicates
+ [to-add (filter (λ (funvar) (not (member funvar existing)))
+ funvars)]}
+ (putprop symbol '*funvars* (append existing to-add))))
+ (void)))
+
+;; chicken and egg - properties defined before sym-set-doc
+(sym-set-doc
+ '*properties*
+ "All properties of symbols recorded with `putprop` are recorded in this table.")
+
+(def (help-print-header term sigs)
+ "Format and print term's signature(s) for `(help term)` output."
+ (if sigs
+ (for-each (λ (sig) (print (cons term sig))
+ (newline))
+ sigs)
+ (begin (print term)
+ (newline)))
+ (newline))
+
+(defmacro (help term (:print-header help-print-header))
+ "Display documentation for the specified term, if available."
+ (let* {[doc (getprop term '*doc*)]+ [sigs (getprop term '*funvars* NIL)]}
+ (if (or doc sigs)
+ `(begin (,print-header ',term ',sigs)
+ (when ,doc
+ (princ ,doc)
+ (newline))
+ (void))
+ (begin (princ "no help for " term)
+ (when (and (sym? term)
+ (not (bound? term)))
+ (princ " (undefined)"))
+ (newline))
+ (void))))
+
+;;; standard procedures
+
+(def (member item lst)
+ (cond ((equal? (car lst) item) lst)
+ (lst (member item (cdr lst)))))
+
+(def (memv item lst)
+ (cond ((eqv? (car lst) item) lst)
+ (lst (memv item (cdr lst)))))
+
+(def (assoc item lst)
+ (cond ((equal? (caar lst) item) (car lst))
+ (lst (assoc item (cdr lst)))))
+
+(def (assv item lst)
+ (cond ((eqv? (caar lst) item) (car lst))
+ (lst (assv item (cdr lst)))))
+
+(def (> a . rest)
+ "Return `T` if the arguments are in strictly decreasing order (previous
+ one is greater than the next one)."
+ (let loop ((a a) (rest rest))
+ (or (not rest)
+ (and (< (car rest) a)
+ (loop (car rest) (cdr rest))))))
+(defmacro (> a . rest)
+ `(< ,@(reverse! rest) ,a))
+
+(def (<= a . rest)
+ "Return `T` if the arguments are in non-decreasing order (previous
+ one is less than or equal to the next one)."
+ (let loop ((a a) (rest rest))
+ (or (not rest)
+ (unless (or (< (car rest) a)
+ (nan? a))
+ (loop (car rest) (cdr rest))))))
+
+(def (>= a . rest)
+ "Return `T` if the arguments are in non-increasing order (previous
+ one is greater than or equal to the next one)."
+ (let loop ((a a) (rest rest))
+ (or (not rest)
+ (unless (or (< a (car rest))
+ (nan? a))
+ (loop (car rest) (cdr rest))))))
+
+(defmacro (/= a . rest)
+ "Return `T` if not all arguments are equal. Shorthand for `(not (= …))`."
+ `(not (= ,a ,@rest)))
+
+(def (negative? x)
+ "Return `T` if `x` is negative."
+ (< x 0))
+
+(def (zero? x)
+ "Return `T` if `x` is zero."
+ (= x 0))
+
+(def (positive? x)
+ "Return `T` if `x` is greater than zero."
+ (> x 0))
+
+(def (even? x)
+ (= (logand x 1) 0))
+
+(def (odd? x)
+ (not (even? x)))
+
+(def (identity x)
+ "Return `x`."
+ x)
+
+(def (1+ n)
+ "Equivalent to `(+ n 1)`."
+ (+ n 1))
+
+(def (1- n)
+ "Equivalent to `(- n 1)`."
+ (- n 1))
+
+(def (div x y)
+ (+ (div0 x y)
+ (or (and (< x 0)
+ (or (and (< y 0) 1)
+ -1))
+ 0)))
+
+(def (mod0 x y)
+ (- x (* (div0 x y) y)))
+
+(def (mod x y)
+ (- x (* (div x y) y)))
+
+(def (random n)
+ (if (int? n)
+ (mod (rand) n)
+ (* (rand-double) n)))
+
+(def (abs x)
+ (if (< x 0)
+ (- x)
+ x))
+
+(def (max x0 . xs)
+ (if xs
+ (foldl (λ (a b) (if (< a b) b a))
+ x0
+ xs)
+ x0))
+
+(def (min x0 . xs)
+ (if xs
+ (foldl (λ (a b) (if (< a b) a b))
+ x0
+ xs)
+ x0))
+
+(def (rune? x)
+ (eq? (typeof x) 'rune))
+
+(def (arr? x)
+ (or (vec? x)
+ (let ((tx (typeof x)))
+ (and (cons? tx) (eq? (car tx) 'arr)))))
+
+(def (closure? x)
+ (and (fn? x)
+ (not (builtin? x))))
+
+(def (caar x) (car (car x)))
+(def (cdar x) (cdr (car x)))
+(def (cddr x) (cdr (cdr x)))
+(def (caaar x) (car (car (car x))))
+(def (caadr x) (car (car (cdr x))))
+(def (cadar x) (car (cdr (car x))))
+(def (caddr x) (car (cdr (cdr x))))
+(def (cdaar x) (cdr (car (car x))))
+(def (cdadr x) (cdr (car (cdr x))))
+(def (cddar x) (cdr (cdr (car x))))
+(def (cdddr x) (cdr (cdr (cdr x))))
+(def (caaaar x) (car (car (car (car x)))))
+(def (caaadr x) (car (car (car (cdr x)))))
+(def (caadar x) (car (car (cdr (car x)))))
+(def (caaddr x) (car (car (cdr (cdr x)))))
+(def (cadaar x) (car (cdr (car (car x)))))
+(def (cadadr x) (car (cdr (car (cdr x)))))
+(def (caddar x) (car (cdr (cdr (car x)))))
+(def (cadddr x) (car (cdr (cdr (cdr x)))))
+(def (cdaaar x) (cdr (car (car (car x)))))
+(def (cdaadr x) (cdr (car (car (cdr x)))))
+(def (cdadar x) (cdr (car (cdr (car x)))))
+(def (cdaddr x) (cdr (car (cdr (cdr x)))))
+(def (cddaar x) (cdr (cdr (car (car x)))))
+(def (cddadr x) (cdr (cdr (car (cdr x)))))
+(def (cdddar x) (cdr (cdr (cdr (car x)))))
+(def (cddddr x) (cdr (cdr (cdr (cdr x)))))
+
+(let ((*values* (list '*values*)))
+ (set! values
+ (λ vs
+ (if (and (cons? vs) (not (cdr vs)))
+ (car vs)
+ (cons *values* vs))))
+ (set! call-with-values
+ (λ (producer consumer)
+ (let ((res (producer)))
+ (if (and (cons? res) (eq? *values* (car res)))
+ (apply consumer (cdr res))
+ (consumer res))))))
+
+;;; list utilities
+
+(def (every pred lst)
+ (or (atom? lst)
+ (and (pred (car lst))
+ (every pred (cdr lst)))))
+
+(def (any pred lst)
+ (and (cons? lst)
+ (or (pred (car lst))
+ (any pred (cdr lst)))))
+
+(def (list? a)
+ (or (not a) (and (cons? a) (list? (cdr a)))))
+
+(def (list-tail lst n)
+ (if (<= n 0)
+ lst
+ (list-tail (cdr lst) (- n 1))))
+
+(def (list-head lst n)
+ (and (> n 0)
+ (cons (car lst)
+ (list-head (cdr lst) (- n 1)))))
+
+(def (list-ref lst n)
+ (car (list-tail lst n)))
+
+(def (length= lst n)
+ "Perform a bounded length test.
+
+ Use this instead of `(= (length lst) n)`, since it avoids unnecessary
+ work and always terminates."
+ (cond ((< n 0) NIL)
+ ((= n 0) (atom? lst))
+ ((atom? lst) (= n 0))
+ (else (length= (cdr lst) (- n 1)))))
+
+(def (length> lst n)
+ (cond ((< n 0) lst)
+ ((= n 0) (and (cons? lst) lst))
+ ((atom? lst) (< n 0))
+ (else (length> (cdr lst) (- n 1)))))
+
+(def (last-pair l)
+ (if (atom? (cdr l))
+ l
+ (last-pair (cdr l))))
+
+(def (lastcdr l)
+ (if (atom? l)
+ l
+ (cdr (last-pair l))))
+
+(def (to-proper l)
+ (cond ((not l) l)
+ ((atom? l) (list l))
+ (else (cons (car l) (to-proper (cdr l))))))
+
+(def (map! f lst)
+ (prog1 lst
+ (while (cons? lst)
+ (set-car! lst (f (car lst)))
+ (set! lst (cdr lst)))))
+
+(def (filter pred lst)
+ (def (filter- f lst acc)
+ (cdr
+ (prog1 acc
+ (while (cons? lst)
+ (when (pred (car lst))
+ (set! acc
+ (cdr (set-cdr! acc (cons (car lst) NIL)))))
+ (set! lst (cdr lst))))))
+ (filter- pred lst (list NIL)))
+
+(def (partition pred lst)
+ (def (partition- pred lst yes no)
+ (let ((vals
+ (prog1
+ (cons yes no)
+ (while (cons? lst)
+ (if (pred (car lst))
+ (set! yes (cdr (set-cdr! yes (cons (car lst) NIL))))
+ (set! no (cdr (set-cdr! no (cons (car lst) NIL)))))
+ (set! lst (cdr lst))))))
+ (values (cdr (car vals)) (cdr (cdr vals)))))
+ (partition- pred lst (list NIL) (list NIL)))
+
+(def (count f l)
+ (def (count- f l n)
+ (if (not l)
+ n
+ (count- f (cdr l) (if (f (car l))
+ (+ n 1)
+ n))))
+ (count- f l 0))
+
+(def (nestlist f zero n)
+ (and (> n 0)
+ (cons zero (nestlist f (f zero) (- n 1)))))
+
+(def (foldr f zero lst)
+ (if (not lst)
+ zero
+ (f (car lst) (foldr f zero (cdr lst)))))
+
+(def (foldl f zero lst)
+ (if (not lst)
+ zero
+ (foldl f (f (car lst) zero) (cdr lst))))
+
+(def (reverse- zero lst)
+ (if (not lst)
+ zero
+ (reverse- (cons (car lst) zero) (cdr lst))))
+
+(def (reverse lst)
+ (reverse- NIL lst))
+
+(def (reverse!- prev l)
+ (while (cons? l)
+ (set! l (prog1 (cdr l)
+ (set-cdr! l (prog1 prev
+ (set! prev l))))))
+ prev)
+
+(def (reverse! l)
+ (reverse!- NIL l))
+
+(def (copy-tree l)
+ (if (atom? l)
+ l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
+(def (delete-duplicates lst)
+ (if (length> lst 20)
+ (let ((ta (table)))
+ (let loop ((l lst) (acc NIL))
+ (if (atom? l)
+ (reverse! acc)
+ (if (has? ta (car l))
+ (loop (cdr l) acc)
+ (begin
+ (put! ta (car l) T)
+ (loop (cdr l) (cons (car l) acc)))))))
+ (if (atom? lst)
+ lst
+ (let ((elt (car lst))
+ (tail (cdr lst)))
+ (if (member elt tail)
+ (delete-duplicates tail)
+ (cons elt
+ (delete-duplicates tail)))))))
+
+; you are not expected to understand this -- spew
+
+(def (zip-with f . lst)
+ (apply map f lst))
+
+(def (zip . lst)
+ (apply map list lst))
+
+;;; backquote
+
+(def (revappend l1 l2)
+ (reverse- l2 l1))
+
+(def (nreconc l1 l2)
+ (reverse!- l2 l1))
+
+(def (self-evaluating? x)
+ (and (not (gensym? x))
+ (or (and (atom? x)
+ (not (sym? x)))
+ (and (const? x)
+ (sym? x)
+ (eq? x (top-level-value x))))))
+
+(defmacro (quasiquote x) (bq-process x 0))
+
+(def (splice-form? x)
+ (or (and (cons? x) (or (eq? (car x) 'unquote-splicing)
+ (eq? (car x) 'unquote-nsplicing)
+ (and (eq? (car x) 'unquote)
+ (length> x 2))))
+ (eq? x 'unquote)))
+
+;; bracket without splicing
+(def (bq-bracket1 x d)
+ (if (and (cons? x) (eq? (car x) 'unquote))
+ (if (= d 0)
+ (cadr x)
+ (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))
+ (bq-process x d)))
+
+(def (bq-bracket x d)
+ (cond ((atom? x) (list list (bq-process x d)))
+ ((eq? (car x) 'unquote)
+ (if (= d 0)
+ (cons list (cdr x))
+ (list list (list cons ''unquote
+ (bq-process (cdr x) (- d 1))))))
+ ((eq? (car x) 'unquote-splicing)
+ (if (= d 0)
+ (list 'copy-list (cadr x))
+ (list list (list list ''unquote-splicing
+ (bq-process (cadr x) (- d 1))))))
+ ((eq? (car x) 'unquote-nsplicing)
+ (if (= d 0)
+ (cadr x)
+ (list list (list list ''unquote-nsplicing
+ (bq-process (cadr x) (- d 1))))))
+ (else (list list (bq-process x d)))))
+
+(def (bq-process x d)
+ (cond ((sym? x) (list 'quote x))
+ ((vec? x)
+ (let ((body (bq-process (vec->list x) d)))
+ (if (eq? (car body) list)
+ (cons vec (cdr body))
+ (list apply vec body))))
+ ((atom? x) x)
+ ((eq? (car x) 'quasiquote)
+ (list list ''quasiquote (bq-process (cadr x) (+ d 1))))
+ ((eq? (car x) 'unquote)
+ (if (and (= d 0) (length= x 2))
+ (cadr x)
+ (list cons ''unquote (bq-process (cdr x) (- d 1)))))
+ ((not (any splice-form? x))
+ (let ((lc (lastcdr x))
+ (forms (map (λ (x) (bq-bracket1 x d)) x)))
+ (if (not lc)
+ (cons list forms)
+ (if (not (cdr forms))
+ (list cons (car forms) (bq-process lc d))
+ (nconc (cons list* forms) (list (bq-process lc d)))))))
+ (else
+ (let loop ((p x) (q NIL))
+ (cond ((not p) ;; proper list
+ (cons 'nconc (reverse! q)))
+ ((cons? p)
+ (cond ((eq? (car p) 'unquote)
+ ;; (... . ,x)
+ (cons 'nconc
+ (nreconc q
+ (if (= d 0)
+ (cdr p)
+ (list (list list ''unquote)
+ (bq-process (cdr p)
+ (- d 1)))))))
+ (else
+ (loop (cdr p) (cons (bq-bracket (car p) d) q)))))
+ (else
+ ;; (... . x)
+ (cons 'nconc (reverse! (cons (bq-process p d) q)))))))))
+
+;;; standard macros
+
+(def (quote-value v)
+ (if (self-evaluating? v)
+ v
+ (list 'quote v)))
+
+(defmacro (let* binds . body)
+ (if (atom? binds)
+ `((λ () ,@body))
+ `((λ (,(caar binds))
+ ,@(if (cons? (cdr binds))
+ `((let* ,(cdr binds) ,@body))
+ body))
+ ,(cadar binds))))
+
+(defmacro (when c . body)
+ (list 'if c (cons 'begin body) NIL))
+
+(defmacro (unless c . body)
+ (list 'if c NIL (cons 'begin body)))
+
+(defmacro (case key . clauses)
+ (def (vals->cond key v)
+ (cond ((eq? v 'else) 'else)
+ ((not v) NIL)
+ ((sym? v) `(eq? ,key ,(quote-value v)))
+ ((atom? v) `(eqv? ,key ,(quote-value v)))
+ ((not (cdr v)) `(eqv? ,key ,(quote-value (car v))))
+ ((every sym? v)
+ `(memq ,key ',v))
+ (else `(memv ,key ',v))))
+ (let ((g (gensym)))
+ `(let ((,g ,key))
+ (cond ,.(map (λ (clause)
+ (cons (vals->cond g (car clause))
+ (cdr clause)))
+ clauses)))))
+
+(defmacro (do vars test-spec . commands)
+ (let ((test-expr (car test-spec))
+ (vars (map car vars))
+ (inits (map cadr vars))
+ (steps (map (λ (x)
+ (if (cons? (cddr x))
+ (caddr x)
+ (car x)))
+ vars)))
+ `(letrec ((loop# (λ ,vars
+ (if ,test-expr
+ (begin
+ ,@(cdr test-spec))
+ (begin
+ ,@commands
+ (loop# ,.steps))))))
+ (loop# ,.inits))))
+
+; SRFI 8
+(defmacro (receive formals expr . body)
+ `(call-with-values (λ () ,expr)
+ (λ ,formals ,@body)))
+
+(defmacro (dotimes var . body)
+ (let ((v (car var))
+ (cnt (cadr var)))
+ `(for 0 (- ,cnt 1)
+ (λ (,v) ,@body))))
+
+(def (map-int f n)
+ (and (> n 0)
+ (let ((first (cons (f 0) NIL))
+ (acc NIL))
+ (set! acc first)
+ (for 1 (1- n)
+ (λ (i) (set-cdr! acc (cons (f i) NIL))
+ (set! acc (cdr acc))))
+ first)))
+
+(def (iota n)
+ (map-int identity n))
+
+(defmacro (with-bindings binds . body)
+ (let ((vars (map car binds))
+ (vals (map cadr binds))
+ (olds (map (λ (x) (gensym)) binds)))
+ `(let ,(map list olds vars)
+ ,@(map (λ (v val) `(set! ,v ,val)) vars vals)
+ (unwind-protect
+ (begin ,@body)
+ (begin ,@(map (λ (v old) `(set! ,v ,old)) vars olds))))))
+
+;;; exceptions
+
+(def (error . args)
+ (raise (cons 'error args)))
+
+(defmacro (throw tag value)
+ `(raise (list 'thrown-value ,tag ,value)))
+
+(defmacro (catch tag expr)
+ `(trycatch ,expr
+ (λ (e#) (if (and (cons? e#)
+ (eq? (car e#) 'thrown-value)
+ (eq? (cadr e#) ,tag))
+ (caddr e#)
+ (raise e#)))))
+
+(defmacro (unwind-protect expr finally)
+ `(let ((thk# (λ () ,finally)))
+ (prog1 (trycatch ,expr
+ (λ (e#) (thk#) (raise e#)))
+ (thk#))))
+
+;;; debugging utilities
+
+(defmacro (assert expr)
+ `(if ,expr T (raise '(assert-failed ,expr))))
+
+(def traced?
+ (let ((sample-traced-lambda (λ args (write (cons 'x args))
+ (newline)
+ (apply #.apply args))))
+ (λ (f)
+ (and (closure? f)
+ (equal? (fn-code f)
+ (fn-code sample-traced-lambda))))))
+
+(def (trace symbol)
+ (let ((func (top-level-value symbol)))
+ (when (not (traced? func))
+ (set-top-level-value! symbol
+ (eval
+ `(λ args#
+ (write (cons ',symbol args#))
+ (newline)
+ (apply ',func args#))))))
+ (void))
+
+(def (untrace symbol)
+ (let ((func (top-level-value symbol)))
+ (when (traced? func)
+ (set-top-level-value! symbol
+ (aref (fn-vals func) 3))))
+ (void))
+
+(defmacro (time expr)
+ `(let ((t0# (time-now)))
+ (prog1
+ ,expr
+ (princ "Elapsed time: " (- (time-now) t0#) " seconds" *linefeed*))))
+
+;;; text I/O
+
+(def (print . args)
+ (for-each write args))
+
+(def (princ . args)
+ (with-bindings ((*print-readably* NIL))
+ (for-each write args)))
+
+(def (newline (io *io-out*))
+ (io-write io *linefeed*)
+ (void))
+
+(def (io-readline s) (io-readuntil s #\linefeed))
+
+; call f on an io until the io runs out of data
+(def (read-all-of f s)
+ (let loop ((lines NIL)
+ (curr (f s)))
+ (if (io-eof? s)
+ (reverse! lines)
+ (loop (cons curr lines) (f s)))))
+
+(def (io-readlines s)
+ (read-all-of io-readline s))
+
+(def (read-all s)
+ (read-all-of read s))
+
+(def (io-readall s)
+ (let ((b (buffer)))
+ (io-copy b s)
+ (io->str b)))
+
+(defmacro (with-output-to io . body)
+ `(with-bindings ((*io-out* ,io))
+ ,@body))
+
+(defmacro (with-input-from io . body)
+ `(with-bindings ((*io-in* ,io))
+ ,@body))
+
+;;; vector functions
+
+(def (list->vec l)
+ (apply vec l))
+
+(def (vec->list v)
+ (let ((n (length v))
+ (l NIL))
+ (for 1 n
+ (λ (i)
+ (set! l (cons (aref v (- n i)) l))))
+ l))
+
+(def (vec-map f v)
+ (let* ((n (length v))
+ (nv (vec-alloc n)))
+ (for 0 (- n 1)
+ (λ (i)
+ (aset! nv i (f (aref v i)))))
+ nv))
+
+;;; table functions
+
+(def (table-pairs ta)
+ (table-foldl (λ (k v z) (cons (cons k v) z))
+ NIL ta))
+(def (table-keys ta)
+ (table-foldl (λ (k v z) (cons k z))
+ NIL ta))
+(def (table-values ta)
+ (table-foldl (λ (k v z) (cons v z))
+ NIL ta))
+(def (table-clone ta)
+ (let ((nt (table)))
+ (table-foldl (λ (k v z) (put! nt k v))
+ NIL ta)
+ nt))
+(def (table-invert ta)
+ (let ((nt (table)))
+ (table-foldl (λ (k v z) (put! nt v k))
+ NIL ta)
+ nt))
+
+;;; string functions
+
+(def (str-tail s n)
+ (str-sub s n))
+
+(def (str-trim s at-start at-end)
+ (def (trim-start s runes i L)
+ (if (and (< i L) (str-find runes (str-rune s i)))
+ (trim-start s runes (1+ i) L)
+ i))
+ (def (trim-end s runes i)
+ (if (and (> i 0) (str-find runes (str-rune s (1- i))))
+ (trim-end s runes (1- i))
+ i))
+ (let ((L (str-length s)))
+ (str-sub s
+ (trim-start s at-start 0 L)
+ (trim-end s at-end L))))
+
+(def (str-map f s)
+ (let ((b (buffer))
+ (n (str-length s)))
+ (let ((i 0))
+ (while (< i n)
+ (io-putc b (f (str-rune s i)))
+ (set! i (1+ i))))
+ (io->str b)))
+
+(def (str-rep s k)
+ (cond ((< k 4)
+ (cond ((<= k 0) "")
+ ((= k 1) (str s))
+ ((= k 2) (str s s))
+ (else (str s s s))))
+ ((odd? k) (str s (str-rep s (- k 1))))
+ (else (str-rep (str s s) (/ k 2)))))
+
+(def (str-lpad s n c)
+ (str (str-rep c (- n (str-length s))) s))
+
+(def (str-rpad s n c)
+ (str s (str-rep c (- n (str-length s)))))
+
+(def (print-to-str . args)
+ (let ((b (buffer)))
+ (for-each (λ (a) (write a b)) args)
+ (io->str b)))
+
+(def (str-join strlist sep)
+ (if (not strlist)
+ ""
+ (let ((b (buffer)))
+ (io-write b (car strlist))
+ (for-each (λ (s) (io-write b sep)
+ (io-write b s))
+ (cdr strlist))
+ (io->str b))))
+
+;;; structs
+
+(defmacro (defstruct name (:type vec)
+ (:named T)
+ (:constructor T)
+ (:conc-name NIL)
+ (:predicate NIL)
+ . slots)
+ "Defines a structure type with a specific name and slots.
+
+ The default underlying type is a \"named\" vector (`:type vec`),
+ where the first element is the name of the structure's type, the
+ rest are the slot values. If the name as the first element isn't
+ required, `:named NIL` should be used. A list can be used instead
+ of a vector by adding `:type list` option.
+
+ An example of a default constructor signature, based on structure
+ definition:
+
+ (defstruct blah a b c) →
+ (make-blah (:a NIL) (:b NIL) (:c NIL))
+
+ It can be customized in several ways. For example:
+
+ ; disable the constructor altogether
+ (defstruct blah :constructor NIL a b c)
+ ; only change its name
+ (defstruct blah :constructor blargh a b c)
+ ; rename AND avoid using keywords
+ (defstruct blah :constructor (blah a b c) a b c)
+
+ The option `:conc-name` specifies the slot accessor prefix, which
+ defaults to `name-`.
+
+ Default predicate name (`name?`) can be changed:
+
+ ; use \"blargh?\" instead of \"blah?\"
+ (defstruct blah :predicate blargh? a b c)"
+ (def (slot-opts slot)
+ ; check whether slot options, if any, are valid
+ (let ((opts (cddr slot)))
+ (for-each (λ (opt) (unless (member opt '(:read-only))
+ (error (str "invalid option in slot " (car slot)
+ " of struct " name
+ ": " opt))))
+ opts)
+ opts))
+ (def (tokw slots)
+ ; transform args list to keyworded variant.
+ ; eg: (a (b 1) (c :read-only)) → ((:a NIL) (:b 1) (:c NIL :read-only))
+ (map! (λ (slot) (let* {[name-cons (and (cons? slot)+ (car slot))]
+ [name (or name-cons slot)]
+ [tail (or (and name-cons
+ (cdr slot))
+ (list NIL))]}
+ (when (or (not (sym? name))
+ (keyword? name))
+ (error "invalid slot name: " name))
+ (list* (sym #\: name)
+ (if (keyword? (car tail))
+ (cons NIL tail)
+ tail))))
+ slots))
+ (let* {; first element in slots may be the doc string+ [doc (and (str? (car slots))
+ (car slots))]
+ ; if it is, rid of it
+ [slots (or (and doc (cdr slots))
+ slots)]
+ [num-slots (length slots)]
+ ; list of slot names
+ [slots-car (map (λ (f) (if (cons? f) (car f) f))
+ slots)]
+ ; slots, but with default values added (if not set)
+ ; and keywords for names
+ [slots-kw (tokw slots)]
+ ; struct's underlying type's predicate (either vec? or list?)
+ [type? (sym type #\?)]
+ ; struct's predicate name
+ [is? (or predicate
+ (sym name #\?))]
+ ; constructor name and arguments
+ [constructor
+ (and constructor ; NIL means none to make at all
+ (or (and (atom? constructor) ; a single argument
+ (cons (or (and (eq? constructor T) ; T means the defaults
+ (sym "make-" name))
+ constructor) ; else a custom name
+ slots-kw))
+ constructor))] ; anything else means custom name and args
+ ; should the struct name appear as the first element?
+ [named (and named (list name))]
+ ; accessor prefix
+ [access (or conc-name
+ (str name "-"))]}
+ `(begin
+ ; predicate
+ (def (,is? s)
+ (and [,type? s]
+ [or (not ',named) (eq? (aref s 0) ',name)]
+ [= (length s) ,(+ (length named) num-slots)]))
+ ; documentation string
+ (when ,doc
+ (sym-set-doc ',name ,doc))
+ ; constructor
+ ,(when constructor `(def ,constructor
+ (,type ',@named ,@slots-car)))
+ ; accessor per slot
+ ,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))]+ [fld (list-ref slots-car i)]
+ [fun (sym access fld)]}
+ `(def (,fun s (v #.(void)))
+ (assert (,is? s))
+ (if (void? v)
+ (aref s ,[+ (length named) i])
+ ,(if (member :read-only opts)
+ `(error (str "slot "
+ ',fld
+ " in struct "
+ ',name
+ " is :read-only"))
+ `(aset! s ,[+ (length named) i] v))))])
+ num-slots))))
+
+(doc-for (defstruct name
+ doc
+ options…
+ (slot-1 DEFAULT)
+ slot-2
+ (slot-3 :read-only)))
+
+;;; toplevel
+
+(def (macrocall? e)
+ (and (sym? (car e))
+ (get-syntax (car e))))
+
+(def (macroexpand-1 e)
+ (if (atom? e)
+ e
+ (let ((f (macrocall? e)))
+ (if f
+ (apply f (cdr e))
+ e))))
+
+(def (macroexpand e)
+ ; symbol resolves to toplevel; i.e. has no shadowing definition
+ (def (top? s env) (not (or (bound? s) (assq s env))))
+
+ (def (splice-begin body)
+ (cond ((atom? body) body)
+ ((equal? body '((begin)))
+ body)
+ ((and (cons? (car body))
+ (eq? (caar body) 'begin))
+ (append (splice-begin (cdar body)) (splice-begin (cdr body))))
+ (else
+ (cons (car body) (splice-begin (cdr body))))))
+
+ (def *expanded* (list '*expanded*))
+
+ (def (expand-body body env)
+ (if (atom? body)
+ body
+ (let* ((body (if (top? 'begin env)
+ (splice-begin body)
+ body))
+ (def? (top? 'def env))
+ (dvars (and def? (get-defined-vars body)))
+ (env (nconc (map list dvars) env)))
+ (if (not def?)
+ (map (λ (x) (expand-in x env)) body)
+ (let* ((ex-nondefs ; expand non-definitions
+ (let loop ((body body))
+ (cond ((atom? body) body)
+ ((and (cons? (car body))
+ (eq? 'def (caar body)))
+ (cons (car body) (loop (cdr body))))
+ (else
+ (let ((form (expand-in (car body) env)))
+ (set! env (nconc
+ (map list (get-defined-vars form))
+ env))
+ (cons
+ (cons *expanded* form)
+ (loop (cdr body))))))))
+ (body ex-nondefs))
+ (while (cons? body) ; now expand deferred definitions
+ (if (not (eq? *expanded* (caar body)))
+ (set-car! body (expand-in (car body) env))
+ (set-car! body (cdar body)))
+ (set! body (cdr body)))
+ ex-nondefs)))))
+
+ (def (expand-lambda-list l env)
+ (if (atom? l)
+ l
+ (cons (if (and (cons? (car l)) (cons? (cdr (car l))))
+ (list (caar l) (expand-in (cadar l) env))
+ (car l))
+ (expand-lambda-list (cdr l) env))))
+
+ (def (l-vars l)
+ (cond ((atom? l) (list l))
+ ((cons? (car l)) (cons (caar l) (l-vars (cdr l))))
+ (else (cons (car l) (l-vars (cdr l))))))
+
+ (def (expand-lambda e env)
+ (let ((formals (cadr e))
+ (name (lastcdr e))
+ (body (cddr e))
+ (vars (l-vars (cadr e))))
+ (let ((env (nconc (map list vars) env)))
+ `(λ ,(expand-lambda-list formals env)
+ ,.(expand-body body env)
+ . ,name))))
+
+ (def (expand-define e env)
+ (if (or (not (cdr e)) (atom? (cadr e)))
+ (if (not (cddr e))
+ e
+ (let* ((name (cadr e))
+ (doc+body (separate-doc-from-body (cddr e)))
+ (doc (car doc+body))
+ (body (cdr doc+body)))
+ (when doc
+ (sym-set-doc name doc))
+ `(def ,name ,(expand-in (car body) env))))
+ (let* ((formals (cdadr e))
+ (name (caadr e))
+ (doc+body (separate-doc-from-body (cddr e)))
+ (doc (car doc+body))
+ (body (cdr doc+body))
+ (vars (l-vars formals))
+ (menv (nconc (map list vars) env)))
+ (when doc
+ (sym-set-doc name doc formals))
+ `(def ,(cons name (expand-lambda-list formals menv))
+ ,.(expand-body body menv)))))
+
+ (def (expand-let-syntax e env)
+ (let ((binds (cadr e)))
+ (cons 'begin
+ (expand-body (cddr e)
+ (nconc
+ (map (λ (bind)
+ (list (car bind)
+ ((compile-thunk
+ (expand-in (cadr bind) env)))
+ env))
+ binds)
+ env)))))
+
+ ; given let-syntax definition environment (menv) and environment
+ ; at the point of the macro use (lenv), return the environment to
+ ; expand the macro use in. TODO
+ (def (local-expansion-env menv lenv) menv)
+
+ (def (expand-in e env)
+ (if (atom? e)
+ e
+ (let* ((head (car e))
+ (bnd (assq head env))
+ (default (λ ()
+ (let loop ((e e))
+ (if (atom? e)
+ e
+ (cons (if (atom? (car e))
+ (car e)
+ (expand-in (car e) env))
+ (loop (cdr e))))))))
+ (cond ((and bnd (cons? (cdr bnd))) ; local macro
+ (expand-in (apply (cadr bnd) (cdr e))
+ (local-expansion-env (caddr bnd) env)))
+ ((macrocall? e) => (λ (f)
+ (expand-in (apply f (cdr e)) env)))
+ ((or bnd ; bound lexical or toplevel var
+ (not (sym? head))
+ (bound? head))
+ (default))
+ ((eq? head 'quote) e)
+ ((eq? head 'λ) (expand-lambda e env))
+ ((eq? head 'lambda) (expand-lambda e env))
+ ((eq? head 'def) (expand-define e env))
+ ((eq? head 'let-syntax) (expand-let-syntax e env))
+ (else (default))))))
+ (expand-in e NIL))
+
+(def (eval x)
+ ((compile-thunk (macroexpand x))))
+
+(def (load-process x)
+ (eval x))
+
+(def (load filename)
+ (let ((F (file filename :read)))
+ (trycatch
+ (let next (prev E v)
+ (if (not (io-eof? F))
+ (next (read F)
+ prev
+ (begin (load-process E) (void)))
+ (begin (io-close F)
+ ; evaluate last form in almost-tail position
+ (void (load-process E)))))
+ (λ (e)
+ (io-close F)
+ (raise `(load-error ,filename ,e))))))
+
+(def (repl)
+ (def (prompt)
+ (*prompt*)
+ (io-flush *io-out*)
+ (let ((v (trycatch (read)
+ (λ (e) (io-discardbuffer *io-in*)
+ (raise e)))))
+ (and (not (io-eof? *io-in*))
+ (let ((V (load-process v)))
+ (unless (void? V) (print V) (newline))
+ (void (set! that V))))))
+ (def (reploop)
+ (when (trycatch (prompt)
+ (λ (e)
+ (top-level-exception-handler e)
+ T))
+ (reploop)))
+ (reploop)
+ (newline))
+
+(def (top-level-exception-handler e)
+ (with-output-to *stderr*
+ (print-exception e)
+ (print-stack-trace (stacktrace))))
+
+(def (print-stack-trace st)
+ (def (find-in-f f tgt path)
+ (let ((path (cons (fn-name f) path)))
+ (if (eq? (fn-code f) (fn-code tgt))
+ (throw 'ffound path)
+ (let ((v (fn-vals f)))
+ (for 0 (1- (length v))
+ (λ (i) (when (closure? (aref v i))
+ (find-in-f (aref v i) tgt path))))))))
+ (def (fname f e)
+ (let ((p (catch 'ffound
+ (begin
+ (for-each (λ (topfun)
+ (find-in-f topfun f NIL))
+ e)
+ NIL))))
+ (if p
+ (str-join (map str (reverse! p)) "/")
+ "λ")))
+ (let ((st (reverse! (if (length> st 3)
+ (list-tail st (if *interactive* 5 4))
+ st)))
+ (e (filter closure? (map (λ (s) (and (bound? s)
+ (top-level-value s)))
+ (environment))))
+ (n 0))
+ (for-each
+ (λ (f)
+ (princ "(" (fname (aref f 1) e))+ (for-each (λ (p) (princ " ") (print p))
+ (cdr (cdr (vec->list f))))
+ (princ ")" *linefeed*)
+ (when (= n 0)
+ (fn-disasm (aref f 1) (aref f 0)))
+ (set! n (+ n 1)))
+ st)))
+
+(def (print-exception e)
+ (cond ((and (cons? e)
+ (eq? (car e) 'type-error)
+ (length= e 3))
+ (princ "type error: expected " (cadr e) ", got " (typeof (caddr e)) ": ")
+ (print (caddr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'bounds-error)
+ (length= e 3))
+ (princ "index " (caddr e) " out of bounds for ")
+ (print (cadr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'unbound-error)
+ (length= e 2))
+ (princ "eval: variable " (cadr e) " has no value"))
+
+ ((and (cons? e)
+ (eq? (car e) 'error))
+ (princ "error: ")
+ (apply princ (cdr e)))
+
+ ((and (cons? e)
+ (eq? (car e) 'load-error))
+ (print-exception (caddr e))
+ (princ "in file " (cadr e)))
+
+ ((and (list? e)
+ (length= e 2))
+ (print (car e))
+ (princ ": ")
+ (let ((msg (cadr e)))
+ ((if (or (str? msg) (sym? msg))
+ princ
+ print)
+ msg)))
+
+ (else (princ "*** Unhandled exception: ")
+ (print e)))
+
+ (princ *linefeed*))
+
+(def (make-system-image fname)
+ (def (sort l)
+ (if (or (not l) (not (cdr l)))
+ l
+ (let ((piv (car l)))
+ (receive (less grtr)
+ (partition (λ (x) (< x piv)) (cdr l))
+ (nconc (sort less)
+ (list piv)
+ (sort grtr))))))
+ (let ((f (file fname :write :create :truncate))
+ (excludes '(*linefeed* *directory-separator* *argv* that *exit-hooks*
+ *print-pretty* *print-width* *print-readably*
+ *print-level* *print-length* *os-name* *interactive*
+ *prompt* *os-version*)))
+ (with-bindings ((*print-pretty* T)
+ (*print-readably* T))
+ (let* ((syms
+ (filter (λ (s)
+ (and (bound? s)
+ (not (const? s))
+ (or (not (builtin? (top-level-value s)))
+ (not (equal? (str s) ; alias of builtin
+ (str (top-level-value s)))))
+ (not (memq s excludes))
+ (not (io? (top-level-value s)))))
+ (sort (environment))))
+ (data (apply nconc (map list syms (map top-level-value syms)))))
+ (write data f)
+ (io-write f *linefeed*))
+ (io-close f))))
+
+; initialize globals that need to be set at load time
+(def (__init_globals)
+ (let ((defprompt (if (equal? *os-name* "macos")
+ (λ () (princ "\x1b[0m\x1b[1m#;> \x1b[0m"))
+ (λ () (princ "#;> ")))))
+ (set! *prompt*
+ "Function called by REPL to signal the user input is required.
+
+ Default function prints `#;> `."
+ defprompt))
+ (set! *directory-separator* (or (and (equal? *os-name* "dos") "\\") "/"))
+ (set! *linefeed* "\n")
+ (set! *exit-hooks* NIL)
+ (set! *io-out* *stdout*)
+ (set! *io-in* *stdin*)
+ (set! *io-err* *stderr*))
+
+(def (__script fname)
+ (trycatch (load fname)
+ (λ (e) (top-level-exception-handler e)
+ (exit (str e)))))
+
+(def (__rcscript)
+ (let* ((homevar (case *os-name*
+ (("unknown") NIL)+ (("plan9") "home")+ (("macos") (princ "\x1b]0;StreetLISP v0.999\007") NIL)+ (else "HOME")))
+ (home (and homevar (os-getenv homevar)))
+ (rcpath (case *os-name*
+ (("plan9") "lib/slrc")+ (else ".slrc")))
+ (fname (and home (str home *directory-separator* rcpath))))
+ (and fname (path-exists? fname) (load fname))))
+
+(def (__start argv interactive)
+ (__init_globals)
+ (set! *argv* argv)
+ (set! *interactive* interactive)
+ (if (cons? (cdr argv))
+ (begin (set! *argv* (cdr argv))
+ (__script (cadr argv)))
+ (set! *interactive* T))
+ (when *interactive*
+ (__rcscript)
+ (repl))
+ (exit))
+
+(def (add-exit-hook fun)
+ "Puts an one-argument function on top of the list of exit hooks.
+
+ On shutdown each exit hook is called with the exit status as a single
+ argument, which is (usually) `NIL` on success and a string describing
+ an error otherwise."
+ (set! *exit-hooks* (cons fun *exit-hooks*))
+ (void))
+
+(def (__finish status)
+ "A function called right before exit by the VM."
+ (for-each (λ (f) (f status)) *exit-hooks*))
--- a/test/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
--- /dev/null
+++ b/test/100x100.sl
@@ -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
--- a/test/argv.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-(print *argv*) (princ "\n")
--- /dev/null
+++ b/test/argv.sl
@@ -1,0 +1,1 @@
+(print *argv*) (princ "\n")
--- a/test/ast/asttools.lsp
+++ /dev/null
@@ -1,167 +1,0 @@
-; utilities for AST processing
-
-(def (list-adjoin item lst)
- (if (member item lst)
- lst
- (cons item lst)))
-
-(def (index-of item lst start)
- (cond ((not lst) NIL)
- ((eq? item (car lst)) start)
- (else (index-of item (cdr lst) (+ start 1)))))
-
-(def (each f l)
- (if (not l) l
- (begin (f (car l))
- (each f (cdr l)))))
-
-(def (maptree-pre f tr)
- (let ((new-t (f tr)))
- (if (cons? new-t)
- (map (lambda (e) (maptree-pre f e)) new-t)
- new-t)))
-
-(def (maptree-post f tr)
- (if (not (cons? tr))
- (f tr)
- (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
- (f new-t))))
-
-(def (foldtree-pre f tr zero)
- (if (not (cons? tr))
- (f tr zero)
- (foldl tr (lambda (e state) (foldtree-pre f e state)) (f tr zero))))
-
-(def (foldtree-post f tr zero)
- (if (not (cons? tr))
- (f tr zero)
- (f tr (foldl tr (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
-(def (map&fold tr zero mapper folder)
- (let ((head (and (cons? tr) (car tr))))
- (cond
- ((eq? head 'quote) tr)
- ((or (eq? head 'the) (eq? head 'meta))
- (list head
- (cadr tr)
- (map&fold (caddr tr) zero mapper folder)))
- (else
- (let ((new-s (folder tr zero)))
- (mapper
- (if (cons? tr)
- ; head symbol is a tag; never transform it
- (cons (car tr)
- (map (lambda (e) (map&fold e new-s mapper folder))
- (cdr tr)))
- tr)
- new-s))))))
-
-; convert to proper list, i.e. remove "dots", and append
-(def (append.2 l tail)
- (cond ((not l) tail)
- ((atom? l) (cons l tail))
- (else (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.
-(def (lexical-walk f tr)
- (map&fold tr () f
- (lambda (tree state)
- (if (and (eq? (car tr) 'lambda)
- (cons? (cdr tr)))
- (append.2 (cadr tr) state)
- state))))
-
-; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
-(def (flatten-left-op op e)
- (maptree-post (lambda (node)
- (if (and (cons? node)
- (eq? (car node) op)
- (cons? (cdr node))
- (cons? (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
-(def (lookup-var v env lev)
- (if (not env) v
- (let ((i (index-of v (car env) 0)))
- (if i (list 'lexref lev i v)
- (lookup-var v (cdr env) (+ lev 1))))))
-(def (lvc- e env)
- (cond ((sym? e) (lookup-var e env 0))
- ((cons? 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)))))
- (else e)))
-(def (lexical-var-conversion e)
- (lvc- e ()))
-
-; convert let to lambda
-(def (let-expand e)
- (maptree-post (lambda (n)
- (if (and (cons? 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) ...)
-(def (alpha-rename e transl)
- (map&fold e
- ()
- ; mapper: replace symbol if unbound
- (lambda (te env)
- (if (sym? te)
- (let ((found (assq te transl)))
- (if (and found
- (not (memq te env)))
- (cdr found)
- te))
- te))
- ; folder: add locals to environment if entering a new scope
- (lambda (te env)
- (if (and (cons? te) (or (eq? (car te) 'let)
- (eq? (car te) 'lambda)))
- (append (cadr te) env)
- env))))
-
-; flatten op with any associativity
-(defmacro (flatten-all-op op e)
- `(pattern-expand
- (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
- (cons ',op (append l (cdr inner) r)))
- ,e))
-
-(defmacro (pattern-lambda pat body)
- (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 . NIL))))
- ',args))
- NIL)))))
--- /dev/null
+++ b/test/ast/asttools.sl
@@ -1,0 +1,167 @@
+; utilities for AST processing
+
+(def (list-adjoin item lst)
+ (if (member item lst)
+ lst
+ (cons item lst)))
+
+(def (index-of item lst start)
+ (cond ((not lst) NIL)
+ ((eq? item (car lst)) start)
+ (else (index-of item (cdr lst) (+ start 1)))))
+
+(def (each f l)
+ (if (not l) l
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(def (maptree-pre f tr)
+ (let ((new-t (f tr)))
+ (if (cons? new-t)
+ (map (lambda (e) (maptree-pre f e)) new-t)
+ new-t)))
+
+(def (maptree-post f tr)
+ (if (not (cons? tr))
+ (f tr)
+ (let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
+ (f new-t))))
+
+(def (foldtree-pre f tr zero)
+ (if (not (cons? tr))
+ (f tr zero)
+ (foldl tr (lambda (e state) (foldtree-pre f e state)) (f tr zero))))
+
+(def (foldtree-post f tr zero)
+ (if (not (cons? tr))
+ (f tr zero)
+ (f tr (foldl tr (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
+(def (map&fold tr zero mapper folder)
+ (let ((head (and (cons? tr) (car tr))))
+ (cond
+ ((eq? head 'quote) tr)
+ ((or (eq? head 'the) (eq? head 'meta))
+ (list head
+ (cadr tr)
+ (map&fold (caddr tr) zero mapper folder)))
+ (else
+ (let ((new-s (folder tr zero)))
+ (mapper
+ (if (cons? tr)
+ ; head symbol is a tag; never transform it
+ (cons (car tr)
+ (map (lambda (e) (map&fold e new-s mapper folder))
+ (cdr tr)))
+ tr)
+ new-s))))))
+
+; convert to proper list, i.e. remove "dots", and append
+(def (append.2 l tail)
+ (cond ((not l) tail)
+ ((atom? l) (cons l tail))
+ (else (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.
+(def (lexical-walk f tr)
+ (map&fold tr () f
+ (lambda (tree state)
+ (if (and (eq? (car tr) 'lambda)
+ (cons? (cdr tr)))
+ (append.2 (cadr tr) state)
+ state))))
+
+; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
+(def (flatten-left-op op e)
+ (maptree-post (lambda (node)
+ (if (and (cons? node)
+ (eq? (car node) op)
+ (cons? (cdr node))
+ (cons? (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
+(def (lookup-var v env lev)
+ (if (not env) v
+ (let ((i (index-of v (car env) 0)))
+ (if i (list 'lexref lev i v)
+ (lookup-var v (cdr env) (+ lev 1))))))
+(def (lvc- e env)
+ (cond ((sym? e) (lookup-var e env 0))
+ ((cons? 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)))))
+ (else e)))
+(def (lexical-var-conversion e)
+ (lvc- e ()))
+
+; convert let to lambda
+(def (let-expand e)
+ (maptree-post (lambda (n)
+ (if (and (cons? 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) ...)
+(def (alpha-rename e transl)
+ (map&fold e
+ ()
+ ; mapper: replace symbol if unbound
+ (lambda (te env)
+ (if (sym? te)
+ (let ((found (assq te transl)))
+ (if (and found
+ (not (memq te env)))
+ (cdr found)
+ te))
+ te))
+ ; folder: add locals to environment if entering a new scope
+ (lambda (te env)
+ (if (and (cons? te) (or (eq? (car te) 'let)
+ (eq? (car te) 'lambda)))
+ (append (cadr te) env)
+ env))))
+
+; flatten op with any associativity
+(defmacro (flatten-all-op op e)
+ `(pattern-expand
+ (pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
+ (cons ',op (append l (cdr inner) r)))
+ ,e))
+
+(defmacro (pattern-lambda pat body)
+ (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 . NIL))))
+ ',args))
+ NIL)))))
--- a/test/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))) ())))
--- /dev/null
+++ b/test/ast/datetimeR.sl
@@ -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))) ())))
--- a/test/ast/match.lsp
+++ /dev/null
@@ -1,179 +1,0 @@
-; tree regular expression pattern matching
-; by Jeff Bezanson
-
-(def (unique lst)
- (and lst
- (cons (car lst)
- (filter (λ (x) (not (eq? x (car lst))))
- (unique (cdr lst))))))
-
-; list of special pattern symbols that cannot be variable names
-(def 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 NIL 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.
-;
-(def (match- p expr state)
- (cond ((sym? p)
- (cond ((eq? p '_) state)
- (else
- (let ((capt (assq p state)))
- (if capt
- (and (equal? expr (cdr capt)) state)
- (cons (cons p expr) state))))))
-
- ((fn? p)
- (and (p expr) state))
-
- ((cons? 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) NIL (list expr) state NIL 1))
- (else
- (and (cons? 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
-(def (match-alt alt prest expr state var L)
- (and alt
- (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)
-(def (match-star- p prest expr state var min max L sofar)
- (cond ; case 0: impossible to match
- ((> min max) NIL)
- ; 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)))))
-(def (match-star p prest expr state var min max L)
- (match-star- p prest expr state var min max L NIL))
-
-; match sequences of expressions
-(def (match-seq p expr state L)
- (cond ((not state) NIL)
- ((not p) (if (not expr) state NIL))
- (else
- (let ((subp (car p))
- (var NIL))
- (if (and (cons? subp)
- (eq? (car subp) '--))
- (begin (set! var (cadr subp))
- (set! subp (caddr subp)))
- NIL)
- (let ((head (if (cons? subp) (car subp) NIL)))
- (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 (cons? expr)
- (match-seq (cdr p) (cdr expr)
- (match- (car p) (car expr) state)
- (- L 1))))))))))
-
-(def (match p expr) (match- p expr (list (cons '__ expr))))
-
-; given a pattern p, return the list of capturing variables it uses
-(def (patargs- p)
- (cond ((and (sym? p)
- (not (member p metasymbols)))
- (list p))
-
- ((cons? p)
- (if (eq? (car p) '-/)
- NIL
- (unique (apply append (map patargs- (cdr p))))))
-
- (else NIL)))
-(def (patargs p)
- (cons '__ (patargs- p)))
-
-; try to transform expr using a pattern-lambda from plist
-; returns the new expression, or expr if no matches
-(def (apply-patterns plist expr)
- (if (not plist) expr
- (if (fn? 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
-(def (pattern-expand plist expr)
- (if (not (cons? 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.sl
@@ -1,0 +1,179 @@
+; tree regular expression pattern matching
+; by Jeff Bezanson
+
+(def (unique lst)
+ (and lst
+ (cons (car lst)
+ (filter (λ (x) (not (eq? x (car lst))))
+ (unique (cdr lst))))))
+
+; list of special pattern symbols that cannot be variable names
+(def 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 NIL 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.
+;
+(def (match- p expr state)
+ (cond ((sym? p)
+ (cond ((eq? p '_) state)
+ (else
+ (let ((capt (assq p state)))
+ (if capt
+ (and (equal? expr (cdr capt)) state)
+ (cons (cons p expr) state))))))
+
+ ((fn? p)
+ (and (p expr) state))
+
+ ((cons? 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) NIL (list expr) state NIL 1))
+ (else
+ (and (cons? 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
+(def (match-alt alt prest expr state var L)
+ (and alt
+ (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)
+(def (match-star- p prest expr state var min max L sofar)
+ (cond ; case 0: impossible to match
+ ((> min max) NIL)
+ ; 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)))))
+(def (match-star p prest expr state var min max L)
+ (match-star- p prest expr state var min max L NIL))
+
+; match sequences of expressions
+(def (match-seq p expr state L)
+ (cond ((not state) NIL)
+ ((not p) (if (not expr) state NIL))
+ (else
+ (let ((subp (car p))
+ (var NIL))
+ (if (and (cons? subp)
+ (eq? (car subp) '--))
+ (begin (set! var (cadr subp))
+ (set! subp (caddr subp)))
+ NIL)
+ (let ((head (if (cons? subp) (car subp) NIL)))
+ (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 (cons? expr)
+ (match-seq (cdr p) (cdr expr)
+ (match- (car p) (car expr) state)
+ (- L 1))))))))))
+
+(def (match p expr) (match- p expr (list (cons '__ expr))))
+
+; given a pattern p, return the list of capturing variables it uses
+(def (patargs- p)
+ (cond ((and (sym? p)
+ (not (member p metasymbols)))
+ (list p))
+
+ ((cons? p)
+ (if (eq? (car p) '-/)
+ NIL
+ (unique (apply append (map patargs- (cdr p))))))
+
+ (else NIL)))
+(def (patargs p)
+ (cons '__ (patargs- p)))
+
+; try to transform expr using a pattern-lambda from plist
+; returns the new expression, or expr if no matches
+(def (apply-patterns plist expr)
+ (if (not plist) expr
+ (if (fn? 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
+(def (pattern-expand plist expr)
+ (if (not (cons? 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/test/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))))))))
--- /dev/null
+++ b/test/ast/rpasses-out.sl
@@ -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))))))))
--- a/test/ast/rpasses.lsp
+++ /dev/null
@@ -1,109 +1,0 @@
-(load "match.lsp")
-(load "asttools.lsp")
-
-(def missing-arg-tag '*r-missing*)
-
-; tree inspection utils
-
-(def (assigned-var e)
- (and (cons? e)
- (or (eq? (car e) '<-) (eq? (car e) 'ref=))
- (sym? (cadr e))
- (cadr e)))
-
-(def (func-argnames f)
- (let ((argl (cadr f)))
- (if (eq? argl '*r-null*) nil
- (map cadr argl))))
-
-; transformations
-
-(let ((ctr 0))
- (set! r-gensym (lambda ()
- (prog1 (sym "%r:" ctr)
- (set! ctr (+ ctr 1))))))
-
-(def (dollarsign-transform e)
- (pattern-expand
- (pattern-lambda ($ lhs name)
- (let* ((g (if (not (cons? lhs)) lhs (r-gensym)))
- (n (if (sym? name)
- name ;(str name)
- name))
- (expr `(r-call
- r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
- (if (not (cons? 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.
-(def (fancy-assignment-transform e)
- (pattern-expand
- (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
- (<<- (r-call f lhs ...) rhs))
- (let ((g (if (cons? rhs) (r-gensym) rhs))
- (op (car __)))
- `(r-block ,@(if (cons? rhs) `((ref= ,g ,rhs)) nil)
- (,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
-(def (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
-(def (normalize-r-functions e)
- (maptree-post (lambda (n)
- (if (and (cons? n) (eq? (car n) 'function))
- `(lambda ,(func-argnames n)
- (r-block ,@(gen-default-inits (cadr n))
- ,@(if (and (cons? (caddr n))
- (eq? (car (caddr n)) 'r-block))
- (cdr (caddr n))
- (list (caddr n)))))
- n))
- e))
-
-(def (find-assigned-vars n)
- (let ((vars nil))
- (maptree-pre (lambda (s)
- (if (not (cons? s)) s
- (cond ((eq? (car s) 'lambda) nil)
- ((eq? (car s) '<-)
- (set! vars (list-adjoin (cadr s) vars))
- (cddr s))
- (else s))))
- n)
- vars))
-
-; introduce let based on assignment statements
-(def (letbind-locals e)
- (maptree-post (lambda (n)
- (if (and (cons? n) (eq? (car n) 'lambda))
- (let ((vars (find-assigned-vars (cddr n))))
- `(lambda ,(cadr n) (let ,(map (lambda (v) (list v nil))
- vars)
- ,@(cddr n))))
- n))
- e))
-
-(def (compile-ish e)
- (letbind-locals
- (normalize-r-functions
- (fancy-assignment-transform
- (dollarsign-transform
- (flatten-all-op && (flatten-all-op \|\| e)))))))
--- /dev/null
+++ b/test/ast/rpasses.sl
@@ -1,0 +1,109 @@
+(load "match.sl")
+(load "asttools.sl")
+
+(def missing-arg-tag '*r-missing*)
+
+; tree inspection utils
+
+(def (assigned-var e)
+ (and (cons? e)
+ (or (eq? (car e) '<-) (eq? (car e) 'ref=))
+ (sym? (cadr e))
+ (cadr e)))
+
+(def (func-argnames f)
+ (let ((argl (cadr f)))
+ (if (eq? argl '*r-null*) nil
+ (map cadr argl))))
+
+; transformations
+
+(let ((ctr 0))
+ (set! r-gensym (lambda ()
+ (prog1 (sym "%r:" ctr)
+ (set! ctr (+ ctr 1))))))
+
+(def (dollarsign-transform e)
+ (pattern-expand
+ (pattern-lambda ($ lhs name)
+ (let* ((g (if (not (cons? lhs)) lhs (r-gensym)))
+ (n (if (sym? name)
+ name ;(str name)
+ name))
+ (expr `(r-call
+ r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
+ (if (not (cons? 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.
+(def (fancy-assignment-transform e)
+ (pattern-expand
+ (pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
+ (<<- (r-call f lhs ...) rhs))
+ (let ((g (if (cons? rhs) (r-gensym) rhs))
+ (op (car __)))
+ `(r-block ,@(if (cons? rhs) `((ref= ,g ,rhs)) nil)
+ (,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
+(def (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
+(def (normalize-r-functions e)
+ (maptree-post (lambda (n)
+ (if (and (cons? n) (eq? (car n) 'function))
+ `(lambda ,(func-argnames n)
+ (r-block ,@(gen-default-inits (cadr n))
+ ,@(if (and (cons? (caddr n))
+ (eq? (car (caddr n)) 'r-block))
+ (cdr (caddr n))
+ (list (caddr n)))))
+ n))
+ e))
+
+(def (find-assigned-vars n)
+ (let ((vars nil))
+ (maptree-pre (lambda (s)
+ (if (not (cons? s)) s
+ (cond ((eq? (car s) 'lambda) nil)
+ ((eq? (car s) '<-)
+ (set! vars (list-adjoin (cadr s) vars))
+ (cddr s))
+ (else s))))
+ n)
+ vars))
+
+; introduce let based on assignment statements
+(def (letbind-locals e)
+ (maptree-post (lambda (n)
+ (if (and (cons? n) (eq? (car n) 'lambda))
+ (let ((vars (find-assigned-vars (cddr n))))
+ `(lambda ,(cadr n) (let ,(map (lambda (v) (list v nil))
+ vars)
+ ,@(cddr n))))
+ n))
+ e))
+
+(def (compile-ish e)
+ (letbind-locals
+ (normalize-r-functions
+ (fancy-assignment-transform
+ (dollarsign-transform
+ (flatten-all-op && (flatten-all-op \|\| e)))))))
--- a/test/bench.lsp
+++ /dev/null
@@ -1,36 +1,0 @@
-(load "test.lsp")
-
-;; each benchmark is repeated N times to accomodate
-;; for the performance increase of current systems
-(def N 100)
-
-;; "Performance and Evaluation of Lisp Systems" (1985), Richard P. Gabriel
-(princ "tak: ")
-(def (tak x y z)
- (if (not (< y x))
- z
- (tak (tak (- x 1) y z)
- (tak (- y 1) z x)
- (tak (- z 1) x y))))
-(time (dotimes (n N) (assert (equal? 7 (tak 18 12 6)))))
-
-;; same as tak, but:
-;; (not (< → (>=
-;; (- ... 1 → (1-
-;; this will show how extra calls (no inlining) make things slow
-(princ "tak_: ")
-(def (tak_ x y z)
- (if (>= y x)
- z
- (tak_ (tak_ (1- x) y z)
- (tak_ (1- y) z x)
- (tak_ (1- z) x y))))
-(time (dotimes (n N) (assert (equal? 7 (tak_ 18 12 6)))))
-
-;; q2 - http://lispology.com/show?314T
-(princ "q2: ")
-(def (q2 x y)
- (if (or (< x 1) (< y 1)) 1
- (+ (q2 (- x (q2 (- x 1) y)) y)
- (q2 x (- y (q2 x (- y 1)))))))
-(time (dotimes (n N) (assert (equal? 31 (q2 7 8)))))
--- /dev/null
+++ b/test/bench.sl
@@ -1,0 +1,36 @@
+(load "test.sl")
+
+;; each benchmark is repeated N times to accomodate
+;; for the performance increase of current systems
+(def N 100)
+
+;; "Performance and Evaluation of Lisp Systems" (1985), Richard P. Gabriel
+(princ "tak: ")
+(def (tak x y z)
+ (if (not (< y x))
+ z
+ (tak (tak (- x 1) y z)
+ (tak (- y 1) z x)
+ (tak (- z 1) x y))))
+(time (dotimes (n N) (assert (equal? 7 (tak 18 12 6)))))
+
+;; same as tak, but:
+;; (not (< → (>=
+;; (- ... 1 → (1-
+;; this will show how extra calls (no inlining) make things slow
+(princ "tak_: ")
+(def (tak_ x y z)
+ (if (>= y x)
+ z
+ (tak_ (tak_ (1- x) y z)
+ (tak_ (1- y) z x)
+ (tak_ (1- z) x y))))
+(time (dotimes (n N) (assert (equal? 7 (tak_ 18 12 6)))))
+
+;; q2 - http://lispology.com/show?314T
+(princ "q2: ")
+(def (q2 x y)
+ (if (or (< x 1) (< y 1)) 1
+ (+ (q2 (- x (q2 (- x 1) y)) y)
+ (q2 x (- y (q2 x (- y 1)))))))
+(time (dotimes (n N) (assert (equal? 31 (q2 7 8)))))
--- a/test/color.lsp
+++ /dev/null
@@ -1,87 +1,0 @@
-; dictionaries ----------------------------------------------------------------
-(def (dict-new) NIL)
-
-(def (dict-extend dl key value)
- (cond ((not 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)))))
-
-(def (dict-lookup dl key)
- (cond ((not dl) NIL)
- ((equal? key (caar dl)) (cdar dl))
- (else (dict-lookup (cdr dl) key))))
-
-(def (dict-keys dl) (map car dl))
-
-; graphs ----------------------------------------------------------------------
-(def (graph-empty) (dict-new))
-
-(def (graph-connect g n1 n2)
- (dict-extend
- (dict-extend g n2 (cons n1 (dict-lookup g n2)))
- n1
- (cons n2 (dict-lookup g n1))))
-
-(def (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
-
-(def (graph-neighbors g n) (dict-lookup g n))
-
-(def (graph-nodes g) (dict-keys g))
-
-(def (graph-add-node g n1) (dict-extend g n1 NIL))
-
-(def (graph-from-edges edge-list)
- (if (not edge-list)
- (graph-empty)
- (graph-connect (graph-from-edges (cdr edge-list))
- (caar edge-list)
- (cdar edge-list))))
-
-; graph coloring --------------------------------------------------------------
-(def (node-colorable? g coloring node-to-color color-of-node)
- (not (member
- color-of-node
- (map
- (λ (n)
- (let ((color-pair (assq n coloring)))
- (and (cons? color-pair) (cdr color-pair))))
- (graph-neighbors g node-to-color)))))
-
-(def (try-each f lst)
- (if (not lst) nil
- (let ((ret (f (car lst))))
- (if ret ret (try-each f (cdr lst))))))
-
-(def (color-node g coloring colors uncolored-nodes color)
- (cond
- ((not uncolored-nodes) coloring)
- ((node-colorable? g coloring (car uncolored-nodes) color)
- (let ((new-coloring
- (cons (cons (car uncolored-nodes) color) coloring)))
- (try-each (λ (c)
- (color-node g new-coloring colors (cdr uncolored-nodes) c))
- colors)))))
-
-(def (color-graph g colors)
- (if (not colors)
- (and (not (graph-nodes g)) nil)
- (color-node g NIL colors (graph-nodes g) (car colors))))
-
-(def (color-pairs pairs colors)
- (color-graph (graph-from-edges pairs) colors))
-
-; queens ----------------------------------------------------------------------
-(def (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))))))
-
-(def (generate-5x5-pairs)
- (let ((result NIL))
- (dotimes (x 25)
- (dotimes (y 25)
- (when (and (/= x y) (can-attack x y))
- (set! result (cons (cons x y) result)))))
- result))
--- /dev/null
+++ b/test/color.sl
@@ -1,0 +1,87 @@
+; dictionaries ----------------------------------------------------------------
+(def (dict-new) NIL)
+
+(def (dict-extend dl key value)
+ (cond ((not 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)))))
+
+(def (dict-lookup dl key)
+ (cond ((not dl) NIL)
+ ((equal? key (caar dl)) (cdar dl))
+ (else (dict-lookup (cdr dl) key))))
+
+(def (dict-keys dl) (map car dl))
+
+; graphs ----------------------------------------------------------------------
+(def (graph-empty) (dict-new))
+
+(def (graph-connect g n1 n2)
+ (dict-extend
+ (dict-extend g n2 (cons n1 (dict-lookup g n2)))
+ n1
+ (cons n2 (dict-lookup g n1))))
+
+(def (graph-adjacent? g n1 n2) (member n2 (dict-lookup g n1)))
+
+(def (graph-neighbors g n) (dict-lookup g n))
+
+(def (graph-nodes g) (dict-keys g))
+
+(def (graph-add-node g n1) (dict-extend g n1 NIL))
+
+(def (graph-from-edges edge-list)
+ (if (not edge-list)
+ (graph-empty)
+ (graph-connect (graph-from-edges (cdr edge-list))
+ (caar edge-list)
+ (cdar edge-list))))
+
+; graph coloring --------------------------------------------------------------
+(def (node-colorable? g coloring node-to-color color-of-node)
+ (not (member
+ color-of-node
+ (map
+ (λ (n)
+ (let ((color-pair (assq n coloring)))
+ (and (cons? color-pair) (cdr color-pair))))
+ (graph-neighbors g node-to-color)))))
+
+(def (try-each f lst)
+ (if (not lst) nil
+ (let ((ret (f (car lst))))
+ (if ret ret (try-each f (cdr lst))))))
+
+(def (color-node g coloring colors uncolored-nodes color)
+ (cond
+ ((not uncolored-nodes) coloring)
+ ((node-colorable? g coloring (car uncolored-nodes) color)
+ (let ((new-coloring
+ (cons (cons (car uncolored-nodes) color) coloring)))
+ (try-each (λ (c)
+ (color-node g new-coloring colors (cdr uncolored-nodes) c))
+ colors)))))
+
+(def (color-graph g colors)
+ (if (not colors)
+ (and (not (graph-nodes g)) nil)
+ (color-node g NIL colors (graph-nodes g) (car colors))))
+
+(def (color-pairs pairs colors)
+ (color-graph (graph-from-edges pairs) colors))
+
+; queens ----------------------------------------------------------------------
+(def (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))))))
+
+(def (generate-5x5-pairs)
+ (let ((result NIL))
+ (dotimes (x 25)
+ (dotimes (y 25)
+ (when (and (/= x y) (can-attack x y))
+ (set! result (cons (cons x y) result)))))
+ result))
--- a/test/err.lsp
+++ /dev/null
@@ -1,4 +1,0 @@
-(def (f x) (begin (list-tail '(1) 3) 3))
-(f 2)
-a
-(trycatch a (λ (e) (print (stacktrace))))
--- /dev/null
+++ b/test/err.sl
@@ -1,0 +1,4 @@
+(def (f x) (begin (list-tail '(1) 3) 3))
+(f 2)
+a
+(trycatch a (λ (e) (print (stacktrace))))
--- a/test/exit0.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-(exit)
--- /dev/null
+++ b/test/exit0.sl
@@ -1,0 +1,1 @@
+(exit)
--- a/test/exit1.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-(exit "error")
--- /dev/null
+++ b/test/exit1.sl
@@ -1,0 +1,1 @@
+(exit "error")
--- a/test/hashtest.lsp
+++ /dev/null
@@ -1,16 +1,0 @@
-(def (hins1)
- (let ((h (table)))
- (dotimes (n 200000)
- (put! h (mod (rand) 1000) 'apple))
- h))
-
-(def (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)))
--- /dev/null
+++ b/test/hashtest.sl
@@ -1,0 +1,16 @@
+(def (hins1)
+ (let ((h (table)))
+ (dotimes (n 200000)
+ (put! h (mod (rand) 1000) 'apple))
+ h))
+
+(def (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)))
--- a/test/mkfile
+++ b/test/mkfile
@@ -1,15 +1,15 @@
TESTS=\
- 100x100.lsp\
- unittest.lsp\
- argv.lsp\
- bench.lsp\
- exit0.lsp\
- hashtest.lsp\
- torus.lsp\
- tme.lsp\
- mp.lsp\
- perf.lsp\
- torture.lsp
+ 100x100.sl\
+ unittest.sl\
+ argv.sl\
+ bench.sl\
+ exit0.sl\
+ hashtest.sl\
+ torus.sl\
+ tme.sl\
+ mp.sl\
+ perf.sl\
+ torture.sl
test:QV:
for(t in $TESTS){--- a/test/mp.lsp
+++ /dev/null
@@ -1,2 +1,0 @@
-(def x 9999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999)
-(apply * (map-int (λ (_) x) 1000))
--- /dev/null
+++ b/test/mp.sl
@@ -1,0 +1,2 @@
+(def x 9999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999)
+(apply * (map-int (λ (_) x) 1000))
--- a/test/number-boundaries.lsp
+++ /dev/null
@@ -1,188 +1,0 @@
-; NUMBER BOUNDARIES ------------------------------------------------------------
-(defmacro (half-max-signed numtype)
- `(ash (,numtype 1)
- (- (* 8 (sizeof ',numtype)) 2)))
-
-(defmacro (high-border-signed numtype)
- `(+ (- (half-max-signed ,numtype) 1)
- (half-max-signed ,numtype)))
-
-(defmacro (low-border-signed numtype)
- `(- -1 (high-border-signed ,numtype)))
-
-(defmacro (low-border numtype)
- `(if (< (,numtype -1) 1)
- (low-border-signed ,numtype)
- (,numtype 0)))
-
-(defmacro (high-border numtype)
- `(lognot (low-border ,numtype)))
- ;`(numtype (lognot (low-border ,numtype))))
-
-(defmacro (number-borders numtype)
- `(cons (low-border ,numtype)
- (high-border ,numtype)))
-
-; TESTS ------------------------------------------------------------------------
-(princ "---\n")
-(princ "s8 " (number-borders s8) "\n")
-(princ "s16 " (number-borders s16) "\n")
-(princ "s32 " (number-borders s32) "\n")
-(princ "s64 " (number-borders s64) "\n")
-(princ "u8 " (number-borders u8) "\n")
-(princ "u16 " (number-borders u16) "\n")
-(princ "u32 " (number-borders u32) "\n")
-(princ "u64 " (number-borders u64) "\n")
-(princ "---\n")
-
-; add/sub signed
-(assert (= 128 (+ (high-border s8) 1)))
-(assert (= 128 (+ 1 (high-border s8))))
-(assert (= -129 (- (low-border s8) 1)))
-(assert (= 129 (- 1 (low-border s8))))
-(assert (= 32768 (+ (high-border s16) 1)))
-(assert (= 32768 (+ 1 (high-border s16))))
-(assert (= -32769 (- (low-border s16) 1)))
-(assert (= 32769 (- 1 (low-border s16))))
-(assert (= 2147483648 (+ (high-border s32) 1)))
-(assert (= 2147483648 (+ 1 (high-border s32))))
-(assert (= -2147483649 (- (low-border s32) 1)))
-(assert (= 2147483649 (- 1 (low-border s32))))
-(assert (= 9223372036854775808 (+ (high-border s64) 1)))
-(assert (= 9223372036854775808 (+ 1 (high-border s64))))
-(assert (= -9223372036854775809 (- (low-border s64) 1)))
-(assert (= 9223372036854775809 (- 1 (low-border s64))))
-(assert (= 27670116110564327421 (+ 9223372036854775807 9223372036854775807 9223372036854775807)))
-(assert (= -12297829382473033728 (+ -3074457345618258432 -3074457345618258432 -3074457345618258432 -3074457345618258432)))
-(assert (= 6148914691236516864 (- -3074457345618258432 -3074457345618258432 -3074457345618258432 -3074457345618258432)))
-
-; conversions
-
-(defmacro (int-conv- smaller bigger)
- `(let* ((h (high-border ,smaller))
- (L (low-border ,bigger))
- (l (if (= L 0) 0 (low-border ,smaller))))
- (assert (and (int? h) (int? l) (num? h) (num? l)))
- (assert (and (num? (,smaller h)) (num? (,smaller l))))
- (assert (and (int? (,smaller h)) (int? (,smaller l))))
- (assert (and (int? (,bigger h)) (int? (,bigger l))))
- (assert (and (num? (,bigger h)) (num? (,bigger l))))
- (assert (and (int-valued? h) (int-valued? l)))
- (assert (and (int-valued? (,smaller h)) (int-valued? (,smaller l))))
- (assert (and (int-valued? (,bigger h)) (int-valued? (,bigger l))))
- (assert (= h
- (,smaller h) (,bigger h)
- (,smaller (,bigger h)) (,bigger (,smaller h))))
- (assert (= l
- (,smaller l) (,bigger l)
- (,smaller (,bigger l)) (,bigger (,smaller l))))))
-
-(defmacro (int-conv smaller . biggers)
- `(void ,@(map (λ (bigger) `(int-conv- ,smaller ,bigger)) biggers)))
-
-(int-conv s8 s8 u8 s16 u16 s32 u32 s64 u64 bignum)
-(int-conv s16 s16 u16 s32 u32 s64 u64 bignum)
-(int-conv s32 s32 u32 s64 u64 bignum)
-(int-conv s64 s64 u64 bignum)
-
-(int-conv u8 u8 u16 s16 u32 s32 u64 s64 bignum)
-(int-conv u16 u16 u32 s32 u64 s64 bignum)
-(int-conv u32 u64 s64 bignum)
-(int-conv u64 bignum)
-
-(int-conv bignum bignum)
-
-(defmacro (float-conv- type)
- `(let ((l (low-border ,type))
- (h (high-border ,type)))
- (if (member ,type (list s64 u64))
- (assert (= 12345 (,type (double 12345))))
- (begin (assert (= l (,type (double l))))
- (assert (= h (,type (double h))))))
- (if (member ,type (list s32 u32 s64 u64))
- (assert (= 12345 (,type (float 12345))))
- (begin
- (assert (= l (,type (float l))))
- (assert (= h (,type (float h))))))))
-
-(defmacro (float-conv . types)
- `(void ,@(map (λ (type) `(float-conv- ,type)) types)))
-
-(float-conv s8 u8 s16 u16 s32 u32 s64 u64)
-
-(assert (= (low-border s32) (bignum (double (low-border s32)))))
-(assert (= (high-border s32) (bignum (double (high-border s32)))))
-(assert (= (low-border s16) (bignum (float (low-border s16)))))
-(assert (= (high-border s16) (bignum (float (high-border s16)))))
-
-(assert (= (low-border s32) (double (s64 (low-border s32)))))
-(assert (= (high-border s32) (double (s64 (high-border s32)))))
-
-(assert (= 0.5f (double (float 0.5))))
-(assert (= 0.5 (float (double 0.5f))))
-
-; comparison of different types
-
-(assert (< (u64 (1- (high-border s64))) (s64 (high-border s64))))
-(assert (< (s64 (high-border s64)) (u64 (1+ (high-border s64)))))
-(assert (< (s64 (high-border s64)) (u64 (1+ (high-border s64)))))
-(assert (< (u64 (1- (high-border s16))) (float (high-border s16))))
-(assert (< (float (high-border s16)) (u64 (1+ (high-border s16)))))
-(assert (< (u64 (1- (high-border s64))) (bignum (high-border s64))))
-(assert (> (u64 (1+ (high-border s64))) (bignum (high-border s64))))
-(assert (< (s64 (1- (high-border s64))) (bignum (high-border s64))))
-(assert (> (s64 (high-border s64)) (bignum (1- (high-border s64)))))
-
-(assert (< (u64 0) (s64 1)))
-(assert (< (s64 0) (u64 1)))
-(assert (> (u64 0) (s64 -1)))
-(assert (< (s64 -1) (u64 0)))
-(assert (< (u64 0) (bignum 1)))
-(assert (< (s64 0) (bignum 1)))
-(assert (> (u64 0) (bignum -1)))
-(assert (> (s64 0) (bignum -1)))
-(assert (< (s64 -1) (bignum 0)))
-(assert (> (u64 (+ 10 (high-border s64))) (s64 (low-border s64))))
-
-(assert (= (u64 1) (s64 1)))
-(assert (= (s64 1) (u64 1)))
-(assert (/= (u64 (high-border u64)) (s64 -1)))
-(assert (/= (s64 -1) (u64 (high-border u64))))
-
-; add/sub unsigned
-(assert (= 256 (+ (high-border u8) 1)))
-(assert (= 256 (+ 1 (high-border u8))))
-(assert (= -1 (- (low-border u8) 1)))
-(assert (= 1 (- 1 (low-border u8))))
-(assert (= 65536 (+ (high-border u16) 1)))
-(assert (= 65536 (+ 1 (high-border u16))))
-(assert (= -1 (- (low-border u16) 1)))
-(assert (= 1 (- 1 (low-border u16))))
-(assert (= 4294967296 (+ (high-border u32) 1)))
-(assert (= 4294967296 (+ 1 (high-border u32))))
-(assert (= -1 (- (low-border u32) 1)))
-(assert (= 1 (- 1 (low-border u32))))
-(assert (= 18446744073709551616 (+ (high-border u64) 1)))
-(assert (= 18446744073709551616 (+ 1 (high-border u64))))
-(assert (= 36893488147419103230 (+ (high-border u64) (high-border u64))))
-(assert (= 36893488147419103231 (+ 1 (high-border u64) (high-border u64))))
-(assert (= 36893488147419103231 (+ (high-border u64) 1 (high-border u64))))
-(assert (= 36893488147419103231 (+ (high-border u64) (high-border u64) 1)))
-(assert (= -1 (- (low-border u64) 1)))
-(assert (= 1 (- 1 (low-border u64))))
-
-; mul signed
-(assert (= 18446744073709551614 (* (high-border s64) 2)))
-(assert (= -18446744073709551614 (* (high-border s64) -2)))
-(assert (= 18446744073709551614 (* 2 (high-border s64))))
-(assert (= -18446744073709551616 (* (low-border s64) 2)))
-(assert (= -18446744073709551616 (* 2 (low-border s64))))
-
-; mul unsigned
-(assert (= 36893488147419103230 (* (high-border u64) 2)))
-(assert (= 36893488147419103230 (* 2 (high-border u64))))
-(assert (= -36893488147419103230 (* (high-border u64) -2)))
-(assert (= -36893488147419103230 (* -2 (high-border u64))))
-
-(princ "all number boundaries tests pass")
-(newline)
--- /dev/null
+++ b/test/number-boundaries.sl
@@ -1,0 +1,188 @@
+; NUMBER BOUNDARIES ------------------------------------------------------------
+(defmacro (half-max-signed numtype)
+ `(ash (,numtype 1)
+ (- (* 8 (sizeof ',numtype)) 2)))
+
+(defmacro (high-border-signed numtype)
+ `(+ (- (half-max-signed ,numtype) 1)
+ (half-max-signed ,numtype)))
+
+(defmacro (low-border-signed numtype)
+ `(- -1 (high-border-signed ,numtype)))
+
+(defmacro (low-border numtype)
+ `(if (< (,numtype -1) 1)
+ (low-border-signed ,numtype)
+ (,numtype 0)))
+
+(defmacro (high-border numtype)
+ `(lognot (low-border ,numtype)))
+ ;`(numtype (lognot (low-border ,numtype))))
+
+(defmacro (number-borders numtype)
+ `(cons (low-border ,numtype)
+ (high-border ,numtype)))
+
+; TESTS ------------------------------------------------------------------------
+(princ "---\n")
+(princ "s8 " (number-borders s8) "\n")
+(princ "s16 " (number-borders s16) "\n")
+(princ "s32 " (number-borders s32) "\n")
+(princ "s64 " (number-borders s64) "\n")
+(princ "u8 " (number-borders u8) "\n")
+(princ "u16 " (number-borders u16) "\n")
+(princ "u32 " (number-borders u32) "\n")
+(princ "u64 " (number-borders u64) "\n")
+(princ "---\n")
+
+; add/sub signed
+(assert (= 128 (+ (high-border s8) 1)))
+(assert (= 128 (+ 1 (high-border s8))))
+(assert (= -129 (- (low-border s8) 1)))
+(assert (= 129 (- 1 (low-border s8))))
+(assert (= 32768 (+ (high-border s16) 1)))
+(assert (= 32768 (+ 1 (high-border s16))))
+(assert (= -32769 (- (low-border s16) 1)))
+(assert (= 32769 (- 1 (low-border s16))))
+(assert (= 2147483648 (+ (high-border s32) 1)))
+(assert (= 2147483648 (+ 1 (high-border s32))))
+(assert (= -2147483649 (- (low-border s32) 1)))
+(assert (= 2147483649 (- 1 (low-border s32))))
+(assert (= 9223372036854775808 (+ (high-border s64) 1)))
+(assert (= 9223372036854775808 (+ 1 (high-border s64))))
+(assert (= -9223372036854775809 (- (low-border s64) 1)))
+(assert (= 9223372036854775809 (- 1 (low-border s64))))
+(assert (= 27670116110564327421 (+ 9223372036854775807 9223372036854775807 9223372036854775807)))
+(assert (= -12297829382473033728 (+ -3074457345618258432 -3074457345618258432 -3074457345618258432 -3074457345618258432)))
+(assert (= 6148914691236516864 (- -3074457345618258432 -3074457345618258432 -3074457345618258432 -3074457345618258432)))
+
+; conversions
+
+(defmacro (int-conv- smaller bigger)
+ `(let* ((h (high-border ,smaller))
+ (L (low-border ,bigger))
+ (l (if (= L 0) 0 (low-border ,smaller))))
+ (assert (and (int? h) (int? l) (num? h) (num? l)))
+ (assert (and (num? (,smaller h)) (num? (,smaller l))))
+ (assert (and (int? (,smaller h)) (int? (,smaller l))))
+ (assert (and (int? (,bigger h)) (int? (,bigger l))))
+ (assert (and (num? (,bigger h)) (num? (,bigger l))))
+ (assert (and (int-valued? h) (int-valued? l)))
+ (assert (and (int-valued? (,smaller h)) (int-valued? (,smaller l))))
+ (assert (and (int-valued? (,bigger h)) (int-valued? (,bigger l))))
+ (assert (= h
+ (,smaller h) (,bigger h)
+ (,smaller (,bigger h)) (,bigger (,smaller h))))
+ (assert (= l
+ (,smaller l) (,bigger l)
+ (,smaller (,bigger l)) (,bigger (,smaller l))))))
+
+(defmacro (int-conv smaller . biggers)
+ `(void ,@(map (λ (bigger) `(int-conv- ,smaller ,bigger)) biggers)))
+
+(int-conv s8 s8 u8 s16 u16 s32 u32 s64 u64 bignum)
+(int-conv s16 s16 u16 s32 u32 s64 u64 bignum)
+(int-conv s32 s32 u32 s64 u64 bignum)
+(int-conv s64 s64 u64 bignum)
+
+(int-conv u8 u8 u16 s16 u32 s32 u64 s64 bignum)
+(int-conv u16 u16 u32 s32 u64 s64 bignum)
+(int-conv u32 u64 s64 bignum)
+(int-conv u64 bignum)
+
+(int-conv bignum bignum)
+
+(defmacro (float-conv- type)
+ `(let ((l (low-border ,type))
+ (h (high-border ,type)))
+ (if (member ,type (list s64 u64))
+ (assert (= 12345 (,type (double 12345))))
+ (begin (assert (= l (,type (double l))))
+ (assert (= h (,type (double h))))))
+ (if (member ,type (list s32 u32 s64 u64))
+ (assert (= 12345 (,type (float 12345))))
+ (begin
+ (assert (= l (,type (float l))))
+ (assert (= h (,type (float h))))))))
+
+(defmacro (float-conv . types)
+ `(void ,@(map (λ (type) `(float-conv- ,type)) types)))
+
+(float-conv s8 u8 s16 u16 s32 u32 s64 u64)
+
+(assert (= (low-border s32) (bignum (double (low-border s32)))))
+(assert (= (high-border s32) (bignum (double (high-border s32)))))
+(assert (= (low-border s16) (bignum (float (low-border s16)))))
+(assert (= (high-border s16) (bignum (float (high-border s16)))))
+
+(assert (= (low-border s32) (double (s64 (low-border s32)))))
+(assert (= (high-border s32) (double (s64 (high-border s32)))))
+
+(assert (= 0.5f (double (float 0.5))))
+(assert (= 0.5 (float (double 0.5f))))
+
+; comparison of different types
+
+(assert (< (u64 (1- (high-border s64))) (s64 (high-border s64))))
+(assert (< (s64 (high-border s64)) (u64 (1+ (high-border s64)))))
+(assert (< (s64 (high-border s64)) (u64 (1+ (high-border s64)))))
+(assert (< (u64 (1- (high-border s16))) (float (high-border s16))))
+(assert (< (float (high-border s16)) (u64 (1+ (high-border s16)))))
+(assert (< (u64 (1- (high-border s64))) (bignum (high-border s64))))
+(assert (> (u64 (1+ (high-border s64))) (bignum (high-border s64))))
+(assert (< (s64 (1- (high-border s64))) (bignum (high-border s64))))
+(assert (> (s64 (high-border s64)) (bignum (1- (high-border s64)))))
+
+(assert (< (u64 0) (s64 1)))
+(assert (< (s64 0) (u64 1)))
+(assert (> (u64 0) (s64 -1)))
+(assert (< (s64 -1) (u64 0)))
+(assert (< (u64 0) (bignum 1)))
+(assert (< (s64 0) (bignum 1)))
+(assert (> (u64 0) (bignum -1)))
+(assert (> (s64 0) (bignum -1)))
+(assert (< (s64 -1) (bignum 0)))
+(assert (> (u64 (+ 10 (high-border s64))) (s64 (low-border s64))))
+
+(assert (= (u64 1) (s64 1)))
+(assert (= (s64 1) (u64 1)))
+(assert (/= (u64 (high-border u64)) (s64 -1)))
+(assert (/= (s64 -1) (u64 (high-border u64))))
+
+; add/sub unsigned
+(assert (= 256 (+ (high-border u8) 1)))
+(assert (= 256 (+ 1 (high-border u8))))
+(assert (= -1 (- (low-border u8) 1)))
+(assert (= 1 (- 1 (low-border u8))))
+(assert (= 65536 (+ (high-border u16) 1)))
+(assert (= 65536 (+ 1 (high-border u16))))
+(assert (= -1 (- (low-border u16) 1)))
+(assert (= 1 (- 1 (low-border u16))))
+(assert (= 4294967296 (+ (high-border u32) 1)))
+(assert (= 4294967296 (+ 1 (high-border u32))))
+(assert (= -1 (- (low-border u32) 1)))
+(assert (= 1 (- 1 (low-border u32))))
+(assert (= 18446744073709551616 (+ (high-border u64) 1)))
+(assert (= 18446744073709551616 (+ 1 (high-border u64))))
+(assert (= 36893488147419103230 (+ (high-border u64) (high-border u64))))
+(assert (= 36893488147419103231 (+ 1 (high-border u64) (high-border u64))))
+(assert (= 36893488147419103231 (+ (high-border u64) 1 (high-border u64))))
+(assert (= 36893488147419103231 (+ (high-border u64) (high-border u64) 1)))
+(assert (= -1 (- (low-border u64) 1)))
+(assert (= 1 (- 1 (low-border u64))))
+
+; mul signed
+(assert (= 18446744073709551614 (* (high-border s64) 2)))
+(assert (= -18446744073709551614 (* (high-border s64) -2)))
+(assert (= 18446744073709551614 (* 2 (high-border s64))))
+(assert (= -18446744073709551616 (* (low-border s64) 2)))
+(assert (= -18446744073709551616 (* 2 (low-border s64))))
+
+; mul unsigned
+(assert (= 36893488147419103230 (* (high-border u64) 2)))
+(assert (= 36893488147419103230 (* 2 (high-border u64))))
+(assert (= -36893488147419103230 (* (high-border u64) -2)))
+(assert (= -36893488147419103230 (* -2 (high-border u64))))
+
+(princ "all number boundaries tests pass")
+(newline)
--- a/test/perf.lsp
+++ /dev/null
@@ -1,62 +1,0 @@
-(load "test.lsp")
-
-(def Y
- (λ (f)
- ((λ (h)
- (f (λ (x) ((h h) x))))
- (λ (h)
- (f (λ (x) ((h h) x)))))))
-
-(def yfib
- (Y (λ (fib)
- (λ (n)
- (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
-
-(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-
-(princ "colorgraph: ")
-(load "tcolor.lsp")
-
-(princ "fib(34): ")
-(assert (equal? (time (fib 34)) 5702887))
-(princ "yfib(32): ")
-(assert (equal? (time (yfib 32)) 2178309))
-
-(def (simple-sort l)
- (if (or (not l) (not (cdr l)))
- l
- (let ((piv (car l)))
- (receive (less grtr)
- (partition (λ (x) (< x piv)) (cdr l))
- (nconc (simple-sort less)
- (list piv)
- (simple-sort grtr))))))
-
-(princ "sort: ")
-(set! r (map-int (λ (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
-(time (simple-sort r))
-
-(princ "macroexpand: ")
-(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
-
-(def (my-append . lsts)
- (cond ((not lsts) NIL)
- ((not (cdr lsts)) (car lsts))
- (else (letrec ((append2 (λ (l d)
- (if (not l)
- d
- (cons (car l)
- (append2 (cdr l) d))))))
- (append2 (car lsts) (apply my-append (cdr lsts)))))))
-
-(princ "append: ")
-(set! L (map-int (λ (x) (map-int identity 20)) 20))
-(time (dotimes (n 1000) (apply my-append L)))
-
-(path-cwd "ast")
-(princ "p-lambda: ")
-(load "rpasses.lsp")
-(def *input* (load "datetimeR.lsp"))
-(time (set! *output* (compile-ish *input*)))
-(assert (equal? *output* (load "rpasses-out.lsp")))
-(path-cwd "..")
--- /dev/null
+++ b/test/perf.sl
@@ -1,0 +1,62 @@
+(load "test.sl")
+
+(def Y
+ (λ (f)
+ ((λ (h)
+ (f (λ (x) ((h h) x))))
+ (λ (h)
+ (f (λ (x) ((h h) x)))))))
+
+(def yfib
+ (Y (λ (fib)
+ (λ (n)
+ (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))))
+
+(def (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
+
+(princ "colorgraph: ")
+(load "tcolor.sl")
+
+(princ "fib(34): ")
+(assert (equal? (time (fib 34)) 5702887))
+(princ "yfib(32): ")
+(assert (equal? (time (yfib 32)) 2178309))
+
+(def (simple-sort l)
+ (if (or (not l) (not (cdr l)))
+ l
+ (let ((piv (car l)))
+ (receive (less grtr)
+ (partition (λ (x) (< x piv)) (cdr l))
+ (nconc (simple-sort less)
+ (list piv)
+ (simple-sort grtr))))))
+
+(princ "sort: ")
+(set! r (map-int (λ (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
+(time (simple-sort r))
+
+(princ "macroexpand: ")
+(time (dotimes (n 5000) (macroexpand '(dotimes (i 100) body1 body2))))
+
+(def (my-append . lsts)
+ (cond ((not lsts) NIL)
+ ((not (cdr lsts)) (car lsts))
+ (else (letrec ((append2 (λ (l d)
+ (if (not l)
+ d
+ (cons (car l)
+ (append2 (cdr l) d))))))
+ (append2 (car lsts) (apply my-append (cdr lsts)))))))
+
+(princ "append: ")
+(set! L (map-int (λ (x) (map-int identity 20)) 20))
+(time (dotimes (n 1000) (apply my-append L)))
+
+(path-cwd "ast")
+(princ "p-lambda: ")
+(load "rpasses.sl")
+(def *input* (load "datetimeR.sl"))
+(time (set! *output* (compile-ish *input*)))
+(assert (equal? *output* (load "rpasses-out.sl")))
+(path-cwd "..")
--- a/test/tcolor.lsp
+++ /dev/null
@@ -1,15 +1,0 @@
-; color for performance
-
-(load "color.lsp")
-
-; 100x color 5 queens
-(def Q (generate-5x5-pairs))
-(def (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/tcolor.sl
@@ -1,0 +1,15 @@
+; color for performance
+
+(load "color.sl")
+
+; 100x color 5 queens
+(def Q (generate-5x5-pairs))
+(def (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/test/test.lsp
+++ /dev/null
@@ -1,56 +1,0 @@
-(let ((*profiles* (table)))
- (set! profile
- (λ (s)
- (let ((f (top-level-value s)))
- (put! *profiles* s (cons 0 0))
- (set-top-level-value! s
- (λ args
- (def tt (get *profiles* s))
- (def count (car tt))
- (def time (cdr tt))
- (def t0 (time-now))
- (def v (apply f args))
- (set-cdr! tt (+ time (- (time-now) t0)))
- (set-car! tt (+ count 1))
- v)))))
- (set! show-profiles
- (λ ()
- (def pr (filter (λ (x) (> (cadr x) 0))
- (table-pairs *profiles*)))
- (def width (+ 4
- (apply max
- (map (λ (x)
- (length (str x)))
- (cons 'Function
- (map car pr))))))
- (princ (str-rpad "Function" width #\ )
- "#Calls Time (seconds)")
- (newline)
- (princ (str-rpad "--------" width #\ )
- "------ --------------")
- (newline)
- (for-each
- (λ (p)
- (princ (str-rpad (str (caddr p)) width #\ )
- (str-rpad (str (cadr p)) 11 #\ )
- (car p))
- (newline))
- (simple-sort (map (λ (l) (reverse (to-proper l)))
- pr)))))
- (set! clear-profiles
- (λ ()
- (for-each (λ (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->vec
- taboreach list-head list-tail assq memq assoc member
- assv memv nreconc bq-process))
--- /dev/null
+++ b/test/test.sl
@@ -1,0 +1,56 @@
+(let ((*profiles* (table)))
+ (set! profile
+ (λ (s)
+ (let ((f (top-level-value s)))
+ (put! *profiles* s (cons 0 0))
+ (set-top-level-value! s
+ (λ args
+ (def tt (get *profiles* s))
+ (def count (car tt))
+ (def time (cdr tt))
+ (def t0 (time-now))
+ (def v (apply f args))
+ (set-cdr! tt (+ time (- (time-now) t0)))
+ (set-car! tt (+ count 1))
+ v)))))
+ (set! show-profiles
+ (λ ()
+ (def pr (filter (λ (x) (> (cadr x) 0))
+ (table-pairs *profiles*)))
+ (def width (+ 4
+ (apply max
+ (map (λ (x)
+ (length (str x)))
+ (cons 'Function
+ (map car pr))))))
+ (princ (str-rpad "Function" width #\ )
+ "#Calls Time (seconds)")
+ (newline)
+ (princ (str-rpad "--------" width #\ )
+ "------ --------------")
+ (newline)
+ (for-each
+ (λ (p)
+ (princ (str-rpad (str (caddr p)) width #\ )
+ (str-rpad (str (cadr p)) 11 #\ )
+ (car p))
+ (newline))
+ (simple-sort (map (λ (l) (reverse (to-proper l)))
+ pr)))))
+ (set! clear-profiles
+ (λ ()
+ (for-each (λ (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->vec
+ taboreach list-head list-tail assq memq assoc member
+ assv memv nreconc bq-process))
--- a/test/tme.lsp
+++ /dev/null
@@ -1,3 +1,0 @@
-(let ((ta (table)))
- (time (dotimes (i 2000000)
- (put! ta (rand) (rand)))))
--- /dev/null
+++ b/test/tme.sl
@@ -1,0 +1,3 @@
+(let ((ta (table)))
+ (time (dotimes (i 2000000)
+ (put! ta (rand) (rand)))))
--- a/test/torture.lsp
+++ /dev/null
@@ -1,30 +1,0 @@
-(def ones (map (λ (x) 1) (iota 1000000)))
-
-(write (apply + ones))
-(newline)
-
-(def (big n)
- (if (<= n 0)
- 0
- `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
-
-; https://todo.sr.ht/~ft/sl/2
-;(def nst (big 100000))
-;(write (eval nst))
-;(newline)
-
-(def longg (cons '+ ones))
-(write (eval longg))
-(newline)
-
-(princ "----- before GC") (newline)
-(vm-stats)
-(gc)
-(princ "----- after GC") (newline)
-(vm-stats)
-(makunbound 'ones)
-(makunbound 'big)
-(makunbound 'longg)
-(gc)
-(princ "----- after makunbound+GC") (newline)
-(vm-stats)
--- /dev/null
+++ b/test/torture.sl
@@ -1,0 +1,30 @@
+(def ones (map (λ (x) 1) (iota 1000000)))
+
+(write (apply + ones))
+(newline)
+
+(def (big n)
+ (if (<= n 0)
+ 0
+ `(+ 1 1 1 1 1 1 1 1 1 1 ,(big (- n 1)))))
+
+; https://todo.sr.ht/~ft/sl/2
+;(def nst (big 100000))
+;(write (eval nst))
+;(newline)
+
+(def longg (cons '+ ones))
+(write (eval longg))
+(newline)
+
+(princ "----- before GC") (newline)
+(vm-stats)
+(gc)
+(princ "----- after GC") (newline)
+(vm-stats)
+(makunbound 'ones)
+(makunbound 'big)
+(makunbound 'longg)
+(gc)
+(princ "----- after makunbound+GC") (newline)
+(vm-stats)
--- a/test/torus.lsp
+++ /dev/null
@@ -1,46 +1,0 @@
-(def (maplist f l)
- (and 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
-(def (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))
-
-(def (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 (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/torus.sl
@@ -1,0 +1,46 @@
+(def (maplist f l)
+ (and 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
+(def (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))
+
+(def (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 (print (torus 100 100)))
+;(time (dotimes (i 1) (load "100x100.sl")))
+; with ltable
+; printing time: 0.415sec
+; reading time: 0.165sec
+
+; with ptrhash
+; printing time: 0.081sec
+; reading time: 0.0264sec
--- a/test/unittest.lsp
+++ /dev/null
@@ -1,773 +1,0 @@
-(defmacro (assert-fail expr . what)
- `(assert (trycatch (begin ,expr NIL)
- (λ (e) ,(if (not what) t
- `(eq? (car e) ',(car what)))))))
-
-(def (every-int n)
- (list (fixnum n) (s8 n) (u8 n) (s16 n) (u16 n) (s32 n) (u32 n)
- (s64 n) (u64 n) (float n) (double n) (bignum n)))
-
-(def (every-sint n)
- (list (fixnum n) (s8 n) (s16 n) (s32 n) (s64 n) (float n) (double n) (bignum n)))
-
-(def (each f l)
- (if (atom? l) NIL
- (begin (f (car l))
- (each f (cdr l)))))
-
-(def (each^2 f l m)
- (each (λ (o) (each (λ (p) (f o p)) m)) l))
-
-(def (test-lt a b)
- (each^2 (λ (neg pos)
- (begin
- (eval `(assert (= -1 (compare ,neg ,pos))))
- (eval `(assert (= 1 (compare ,pos ,neg))))
- (eval `(assert (< ,neg ,pos)))
- (eval `(assert (not (< ,pos ,neg))))))
- a
- b))
-
-(def (test-eq a b)
- (each^2 (λ (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))
-
-(def (test-square a)
- (each (λ (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 INT32_MIN
-(assert (< (- #u32(0x80000000)) 0))
-(assert (> (- #s32(0x80000000)) 0))
-(assert (< (- #u64(0x8000000000000000)) 0))
-(assert (< (- #s64(0x8000000000000000)) 0))
-; fixnum versions
-(assert (= (- -536870912) 536870912))
-(assert (= (- -2305843009213693952) 2305843009213693952))
-
-(assert (not (equal? #s64(0x8000000000000000) #u64(0x8000000000000000))))
-(assert (equal? (+ #s64(0x4000000000000000) #s64(0x4000000000000000))
- #u64(0x8000000000000000)))
-(assert (equal? (* 2 #s64(0x4000000000000000))
- #u64(0x8000000000000000)))
-
-(assert (equal? (u64 (double -123)) #u64(0xffffffffffffff85)))
-
-(assert (equal? (str 'sym #byte(65) #rune(945) "blah") "symA\u03B1blah"))
-(assert (= (length (str #\x0)) 1))
-
-(assert (> 9223372036854775808 9223372036854775807))
-
-(assert (fixnum? (- (aref "0" 0) #\0)))
-
-(assert (= (ash #bignum(1) -9999) 0))
-
-; number boundaries
-(load "number-boundaries.lsp")
-
-; bignum
-(assert (> 0x10000000000000000 0x8fffffffffffffff))
-(assert (< 0x8fffffffffffffff 0x10000000000000000))
-
-(assert (bignum? (ash 2 60)))
-(def (bignum-on-32? x) (if #.(fixnum? 0xffffffff) (not (bignum? x)) (bignum? x)))
-(assert (bignum-on-32? (- (ash 2 60) 1)))
-(assert (bignum? 1606938044258990275541962092341162602522202993782792835301376))
-(assert (bignum? 0xfffffffffffffffff))
-(assert (bignum-on-32? 0xfffffffffffffff))
-
-(assert (= 4764984380238568507752444984131552966909
- (* 66405897020462343733 71755440315342536873)))
-(assert (= 71755440315342536873
- (div 4764984380238568507752444984131552966909 66405897020462343733)))
-(assert (= 3203431780337 (div 576460752303423487 179951)))
-(assert (= 3487 (mod 576460752303423487 18000)))
-(assert (= 7 (mod 576460752303423487 10)))
-
-(assert (= 0xfffffffffffffffff (logior 0xaaaaaaaaaaaaaaaaa 0x55555555555555555)))
-(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
-(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
-(assert (= 0xaaaaaaaaa (logand 0xaaaaaaaaaaaaaaaaa 0x55555555fffffffff)))
-(assert (= 0 (logand 0 0x55555555555555555)))
-(assert (= 602394779747 (ash 11112222333344445555666677778888 -64)))
-(assert (= 204984321473364576635441321909950327706185271083008
- (ash 11112222333344445555666677778888 64)))
-
-; NaNs
-(assert (nan? +nan.0))
-(assert (nan? -nan.0))
-(assert (nan? (float +nan.0)))
-(assert (nan? (float -nan.0)))
-(assert (equal? +nan.0 +nan.0))
-(assert (equal? -nan.0 -nan.0))
-(assert (equal? (float +nan.0) (float +nan.0)))
-(assert (equal? (float -nan.0) (float -nan.0)))
-(assert (/= +nan.0 +nan.0))
-(assert (/= +nan.0 -nan.0))
-(assert (/= -nan.0 -nan.0))
-(assert (/= (float +nan.0) (float +nan.0)))
-(assert (/= (float +nan.0) (float -nan.0)))
-(assert (/= (float -nan.0) (float -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)))
-(assert (not (<= -nan.0 -nan.0)))
-(assert (not (>= (float +nan.0) (float +nan.0))))
-(assert (not (<= (float -nan.0) (float -nan.0))))
-
-; comparing strings
-(assert (< "a" "b"))
-(assert (< "a" "b" "c"))
-(assert (> "b" "a"))
-(assert (> "c" "b" "a"))
-(assert (not (< "a" "a")))
-(assert (not (< "a" "a" "a")))
-(assert (<= "a" "a"))
-(assert (<= "a" "a" "a"))
-(assert (>= "a" "a"))
-(assert (>= "a" "a" "a"))
-(assert (>= "ab" "aa"))
-(assert (>= "ab" "aa" "aa"))
-
-; one or more than two arguments
-(assert (and (> 0) (< 0) (>= 0) (<= 0)))
-(assert (and (> 2 1 0) (< 0 1 2) (>= 2 1 0) (<= 0 1 2)))
-(assert (and (>= 2 1 1) (<= 1 1 2)))
-(assert (not (and (>= 2 1 2) (<= 2 1 2))))
-
-; comparing numbers and runes
-(assert (< 9 #\newline))
-(assert (not (< 10 #\newline)))
-(assert (= 10 #\newline))
-(assert (> 11 #\newline))
-
-; -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))
-; same but float
-(assert (not (equal? 0.0f 0)))
-(assert (equal? 0.0f 0.0f))
-(assert (not (equal? -0.0f 0.0f)))
-(assert (not (equal? -0.0f 0)))
-(assert (not (eqv? 0.0f 0)))
-(assert (not (eqv? -0.0f 0)))
-(assert (not (eqv? -0.0f 0.0f)))
-(assert (= 0.0f -0.0f))
-
-; this crashed once
-(for 1 10 (λ (i) 0))
-
-; and, or
-(assert (equal? T (and)))
-(assert (equal? NIL (or)))
-(assert (equal? 1 (and '(1) 'x 1)))
-(assert (equal? 1 (or NIL NIL NIL NIL NIL 1 NIL NIL NIL NIL)))
-(assert (equal? 2 (if (and '(1) 'x 1) 2 0)))
-(assert (equal? 2 (if (or NIL NIL NIL NIL NIL 1 NIL NIL NIL NIL) 2 0)))
-(assert (equal? NIL (and '(1) 1 'x NIL)))
-(assert (equal? NIL (or NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)))
-(assert (equal? 0 (if (and '(1) 1 'x NIL) 2 0)))
-(assert (equal? 0 (if (or NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) 2 0)))
-
-; failing applications
-(assert-fail ((λ (x) x) 1 2))
-(assert-fail ((λ (x) x)))
-(assert-fail ((λ (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))
-(def ones (map (λ (x) 1) (iota 80000)))
-(assert (= (eval `(if (< 2 1)
- (+ ,@ones)
- (+ ,@(cdr ones))))
- 79999))
-
-(def MAX_ARGS 255)
-
-(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 1))))
-(def f (compile `(λ ,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))))
-
-(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 100))))
-(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
- ,(car (last-pair as)))))
-(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
-(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
- (λ () ,(car (last-pair as))))))
-(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
-
-(def as (map-int (λ (x) (gensym)) 1000))
-(def f (compile `(λ ,as ,(car (last-pair as)))))
-(assert (equal? (apply f (iota 1000)) 999))
-
-(def as (apply list* (map-int (λ (x) (gensym)) 995)))
-(def f (compile `(λ ,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? ((λ ((b 0)) b)) 0))
-(assert (equal? ((λ (a (b 2)) (list a b)) 1) '(1 2)))
-(assert (equal? ((λ (a (b 2)) (list a b)) 1 3) '(1 3)))
-(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
-(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
-(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
-(assert (equal? ((λ ((x 0) . r) (list x r))) '(0 NIL)))
-(assert (equal? ((λ ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
-
-; keyword arguments
-(assert (keyword? :kw))
-(assert (not (keyword? 'kw:)))
-(assert (not (keyword? 'kw)))
-(assert (not (keyword? ':)))
-(assert (equal? ((λ (x (a 2) (:b a) . r) (list x a b r)) 1 0 8 4 5)
- '(1 0 0 (8 4 5))))
-(assert (equal? ((λ (x (a 2) (:b a) . r) (list x a b r)) 0 :b 3 1)
- '(0 2 3 (1))))
-(def (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
-(def (keys1 (:a 8)) (+ a 1))
-(assert (equal? (keys1 :a 11) 12))
-
-; cvalues and arrays
-(assert (equal? (typeof "") '(arr byte)))
-(assert-fail (aref #(1) 3) bounds-error)
-(def iarr (arr 's64 32 16 8 7 1))
-(assert (equal? (aref iarr 0) 32))
-(assert (equal? (aref iarr #s8(3)) 7))
-
-; gensyms
-(assert (gensym? (gensym)))
-(assert (not (gensym? 'a)))
-(assert (not (eq? (gensym) (gensym))))
-(assert (not (equal? (str (gensym)) (str (gensym)))))
-(let ((gs (gensym))) (assert (eq? gs gs)))
-
-(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)))))
-
-(assert (let ((ts (time->str (time-now))))
- (eqv? ts (time->str (str->time 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
-
-(def (with-output-to-str nada thunk)
- (let ((b (buffer)))
- (with-output-to b (thunk))
- (io->str b)))
-
-(let ((c #\a))
- (assert (equal? (with-output-to-str NIL (λ () (print (list c c))))
- "(#\\a #\\a)")))
-
-(assert-fail (eval '(set! (car (cons 1 2)) 3)))
-
-(assert (equal? `(a `(b c)) '(a (quasiquote (b c)))))
-(assert (equal? ````x '```x))
-
-(assert-fail (eval '(append 1)))
-(assert-fail (eval '(append NIL 1)))
-(assert (equal? (append) NIL))
-(assert (equal? (append NIL) NIL))
-(assert (equal? (append NIL NIL) NIL))
-(assert (equal? (append '(1 2)) '(1 2)))
-(assert (equal? (append '(1 2) '(3 4)) '(1 2 3 4)))
-
-;; infinite list
-(def a '(1))
-(set-cdr! a a)
-(assert (equal? (length a) +inf.0))
-(eq? (cdr a) a)
-
-;; unbinding
-(def abc 1)
-(assert (equal? (bound? 'abc) T))
-(assert (equal? (eval '(+ abc 1)) 2))
-(makunbound 'abc)
-(assert (equal? (bound? 'abc) NIL))
-(assert-fail (eval '(+ abc 1)))
-
-;; c***r of empty list
-(assert (not (car NIL)))
-(assert (not (cdr NIL)))
-(assert (not (cadr NIL)))
-(assert (not (cdar NIL)))
-(assert (not (caaar NIL)))
-(assert (not (cdddr NIL)))
-
-;; for-each with multiple lists
-(def q NIL)
-(for-each (λ (x y) (set! q (cons (+ x y) q))) #(1 2 3) #vu8(4 5 6))
-(assert (equal? q '(9 7 5)))
-(def q 0)
-(for-each (λ (x y) (set! q (+ x y q))) '(1) '(3 9))
-(assert (equal? q 4))
-(for-each (λ (x y) (set! q (+ x y q))) '(1 2) '(3))
-(assert (equal? q 8))
-(for-each (λ (x y z) (set! q (+ x y z q))) '(1 2) '(3) '(4 5))
-(assert (equal? q 16))
-
-;; map with multiple lists
-(assert (equal? (map (λ (x y z) (+ x y z)) '(1 2 3) '(4 5 6) '(7 8 9)) '(12 15 18)))
-(assert (equal? (map (λ (x y) (+ x y)) '(1) '(3 9)) '(4)))
-(assert (equal? (map (λ (x y) (+ x y)) '(1 2) '(3)) '(4)))
-(assert (equal? (map (λ (x y z) (+ x y z)) '(1 2) '(3) '(4 5)) '(8)))
-
-;; aref with multiple indices
-(def a #(#(0 1 2) #(3 (4 5 6) 7)))
-(assert (equal? 0 (aref a 0 0)))
-(assert (equal? 0 (apply aref (list a 0 0))))
-(assert (equal? 2 (aref a 0 2)))
-(assert (equal? 3 (aref a (1+ 0) 0)))
-(assert (equal? 7 (aref a 1 2)))
-(assert (equal? 5 (aref a 1 (1+ 0) 1)))
-(assert-fail (aref a 1 1 3) bounds-error)
-(assert (equal? (fixnum #\l) (aref #("hello") 0 2)))-(assert (equal? (fixnum #\o) (aref #("hello") 0 (1+ 3))))-(assert-fail (aref #("hello") 0 5))-(assert-fail (aref #("hello") 1 0))-(assert-fail (aref '(NIL) 0 0))
-(assert-fail (apply aref '((NIL) 0 0)))
-
-;; aset with multiple indices
-(def a #(#(0 1 2) #(3 (4 5 6) 7)))
-(assert (equal? 8 (apply aset! (list a 0 0 8))))
-(assert (equal? 9 (aset! a 1 1 (1+ 1) 9)))
-(assert (equal? "hello" (aset! a (1+ 0) 2 "hello")))
-(assert-fail (aset! a 1 1 3 "nope"))
-(assert (equal? a #(#(8 1 2) #(3 (4 5 9) "hello"))))
-(assert-fail (aset! '(NIL) 0 0 1))
-(assert-fail (apply aset! '((NIL) 0 0 1)))
-
-;; apply with multiple args
-(assert (equal? 15 (apply + 1 2 '(3 4 5))))
-(assert-fail (apply + 1 2 3)) ; last arg not a list
-
-;; make many initialized tables large enough not to be stored in-line
-(for 1 100 (λ (i)
- (table eq? 2 eqv? 2
- equal? 2 atom? 1
- not 1 nan? 1
- cons? 1 sym? 1
- num? 1 bound? 1
- cons? 1 builtin? 1
- vec? 1 fixnum? 1
- cons 2 car 1
- cdr 1 set-car! 2
- set-cdr! 2 = 2
- < 2 compare 2
- aref 2 aset! 3
- div0 2 'hello 4
- 'goodbye 5 'foo 6
- 'bar 7)))
-;; now allocate enough to trigger GC
-(for 1 8000000 (λ (i) (cons 1 2)))
-
-;; brieflz bindings
-(let* ((level 10)
- (s (file "unittest.lsp"))
- (in (io-readall s))
- (packed (lz-pack in level))
- (unpacked (lz-unpack packed :size (sizeof in)))
- (unpacked2 (arr-alloc 'byte (sizeof in) 0)))
- (io-close s)
- (assert (< (sizeof packed) (sizeof in)))
- (assert (equal? in unpacked))
- (assert (eq? unpacked2 (lz-unpack packed :to unpacked2)))
- (assert (equal? in unpacked2))
- (princ "lz packing at level " level ": " (sizeof in) " → " (sizeof packed))
- (newline))
-
-;; macro vs function priority
-(def (!! x y) (- x y))
-(assert (eq? 3 (!! 5 2)))
-(defmacro (!! x y z) (+ z (apply !! (list x y))))
-(assert (eq? 4 (!! 5 2 1)))
-
-(def s "привет\0пока")
-(def s2 "hello \t \n world\n ")
-
-(assert (eq? 21 (sizeof s)))
-(assert (eq? 21 (length s)))
-(assert (eq? 11 (str-length s)))
-(assert (eq? 11 (str-length s 0)))
-(assert (eq? 10 (str-length s 2)))
-(assert (eq? 9 (str-length s 3)))
-(assert (eq? 0 (str-length s 21)))
-(assert-fail (str-length s -1))
-(assert-fail (str-length s 22))
-(assert (eq? 1 (str-length s 0 2)))
-(assert (eq? 2 (str-length s 0 4)))
-(assert (eq? 0 (str-length s 21 20)))
-(assert (eq? 0 (str-length s 21 21)))
-(assert-fail (str-length s 21 22))
-
-(assert (equal? "акоп\0тевирп" (str-reverse s)))
-(assert (equal? "" (str-reverse "")))
-(assert (equal? "й" (str-reverse "й")))
-(assert (equal? "wб☺🡷⁹гq" (str-reverse "qг⁹🡷☺бw")))
-
-(assert (str-utf8? ""))
-(assert (str-utf8? "wб☺🡷⁹гq"))
-(assert (not (str-utf8? "\xfffe")))
-
-(let ((b (buffer)))
- (write "a\x0a\x09\\\x07\x08\x1b\x0c\x0d\x0b" b)
- (assert (equal? (io->str b) "\"a\\n\\t\\\\\\a\\b\\e\\f\\r\\v\"")))
-
-(assert (= 10 (str-width s)))
-(assert (= 0 (str-width "")))
-(assert (= 1 (str-width #\q)))
-(assert (= 1 (str-width #\й)))
-(assert (= 0 (str-width #\nul)))
-(assert-fail (str-width 123))
-(assert-fail (str-width 'blah))
-(assert-fail (str-width str-width))
-
-(assert (equal? '("привет" "пока") (str-split s "\0")))-(assert (equal? '("пр" "вет" "пок" "") (str-split s "аи\0")))-(assert (equal? '("" "") (str-split "1" "1")))-
-(assert (equal? '("hello" "world") (str-split s2 :trim T)))-(assert (equal? '("hello" "\t" "\n" "world\n") (str-split s2 " " :trim T)))-(assert (equal? (list s2) (str-split s2 "X" :trim T)))
-(assert (equal? (list s2) (str-split s2 "X")))
-
-(assert (equal? #\а (str-rune s 10)))
-(assert (equal? #\nul (str-rune s 6)))
-(assert-fail (str-rune s 11))
-
-(assert (equal? #\W (rune-upcase #\w)))
-(assert (equal? #\П (rune-upcase #\п)))
-(assert (equal? #\nul (rune-upcase #\nul)))
-
-(assert (rune-upper-case? #\W))
-(assert (rune-upper-case? #\П))
-(assert (not (rune-upper-case? #\nul)))
-(assert (not (rune-upper-case? #\w)))
-(assert (not (rune-upper-case? #\п)))
-(assert (not (rune-upper-case? #\nul)))
-
-(assert (equal? #\w (rune-downcase #\W)))
-(assert (equal? #\п (rune-downcase #\П)))
-(assert (equal? #\nul (rune-downcase #\nul)))
-
-(assert (rune-lower-case? #\w))
-(assert (rune-lower-case? #\п))
-(assert (not (rune-lower-case? #\nul)))
-(assert (not (rune-lower-case? #\W)))
-(assert (not (rune-lower-case? #\П)))
-(assert (not (rune-lower-case? #\nul)))
-
-(assert (rune-numeric? #\0))
-(assert (rune-numeric? #\9))
-(assert (not (rune-numeric? #\⁰)))
-(assert (not (rune-numeric? #\q)))
-
-(assert (rune-whitespace? #\space))
-(assert (rune-whitespace? #\tab))
-(assert (rune-whitespace? #\vtab))
-(assert (rune-whitespace? #\newline))
-(assert (rune-whitespace? #\x00a0))
-(assert (rune-whitespace? #\x3000))
-(assert (not (rune-whitespace? #\x200b)))
-
-(assert (rune-alphabetic? #\q))
-(assert (rune-alphabetic? #\й))
-(assert (not (rune-alphabetic? #\⁰)))
-(assert (not (rune-alphabetic? #\0)))
-
-(assert (not (rune-title-case? #\DŽ)))
-(assert (equal? #\Dž (rune-titlecase #\DŽ)))
-(assert (rune-title-case? #\Dž))
-
-(def s "hello й goodbye")
-(assert (= 4 (str-find s #\o)))
-(assert (= 9 (str-find s #\o 5)))
-(assert (= 10 (str-find s #\o 10)))
-(assert (not (str-find s #\o 11)))
-(assert (not (str-find s #\o 15)))
-(assert (= 4 (str-find s "o")))
-(assert (= 2 (str-find s "ll")))
-(assert (not (str-find s "ll" 3)))
-(assert (= 0 (str-find s "")))
-(assert (= 7 (str-find s "" 7)))
-(assert (= 6 (str-find s #\й)))
-(assert (= 6 (str-find s #\й 6)))
-(assert-fail (str-find s #\o -1))
-(assert-fail (str-find s #\o 16))
-(assert-fail (str-find s 0))
-(assert-fail (str-find s (byte #\o)))
-
-(assert (equal? "1.5" (num->str 1.5)))
-(assert (equal? "-3039" (num->str (s16 -12345) 16)))
-(assert (equal? "111111111111111111111111111111111" (num->str 111111111111111111111111111111111)))
-(assert (equal? "fffffffffffffffffffffffffffffffff" (num->str 0xfffffffffffffffffffffffffffffffff 16)))
-
-(assert-fail (num->str 1.5 16))
-(assert-fail (num->str (bignum 0) 36))
-
-(assert (= 1.5 (str->num "1.5")))
-(assert (= -12345 (str->num "-3039" 16)))
-(assert (= 111111111111111111111111111111111 (str->num "111111111111111111111111111111111")))
-(assert (= 0xfffffffffffffffffffffffffffffffff (str->num "fffffffffffffffffffffffffffffffff" 16)))
-
-(assert (= (length (byte #\f)) 1))
-(assert (= (length #\я) 2))
-(assert (= (length #\⁹) 3))
-(assert-fail (= (length (u8 0)) 1))
-(assert-fail (= (length (u16 0)) 2))
-(assert-fail (= (length (u32 0)) 4))
-(assert-fail (= (length (u64 0)) 4))
-(assert-fail (= (length (bignum 0)) 0))
-
-(assert (eq? (sym 'blah) 'blah))
-(assert (eq? (sym "hi" "there" 'symbol 123) 'hitheresymbol123))
-
-(assert-fail (exit "error" 2))
-
-(assert (int-valued? 1.0))
-(assert (int-valued? -1.0))
-(assert (int-valued? 1.0f))
-(assert (int-valued? -1.0f))
-(assert (int-valued? (bignum 0)))
-
-(assert (num? 1.3))
-(assert (num? -1.3))
-(assert (num? 1.3f))
-(assert (num? -1.3f))
-(assert (not (num? #\я)))
-
-(assert (int? 0))
-(assert (int? (bignum 0)))
-
-(assert (= 12345 (fixnum (bignum 12345))))
-(assert (= -12345 (fixnum (bignum -12345))))
-
-(assert (= 1.0 (truncate 1.3)))
-(assert (= -1.0 (truncate -1.3)))
-(assert (= 1.0 (truncate 1.3)))
-(assert (= -1.0 (truncate -1.3)))
-(assert (= 1.0 (truncate 1.3f)))
-(assert (= -1.0 (truncate -1.3f)))
-(assert (= 1.0 (truncate 1.3f)))
-(assert (= -1.0 (truncate -1.3f)))
-(assert (= 1 (truncate (bignum 1))))
-(assert (= -1 (truncate (bignum -1))))
-(assert (= 123 (truncate (s64 123))))
-(assert (= -123 (truncate (s8 -123))))
-(assert-fail (truncate "blah"))
-(assert-fail (truncate 'blah))
-(assert-fail (truncate truncate))
-
-(assert (= 0 (sin 0)))
-(assert (= 0 (sin 0.0)))
-(assert (= 0 (sin 0.0f)))
-(assert (= 0 (sin (s64 0))))
-(assert (= 0 (sin (bignum 0))))
-(let ((x (cos 0)))
- (assert (and (>= x 0.999999999999999) (<= x 1.0))))
-(assert (= 3 (sqrt 9)))
-(assert (= 3 (log10 1000)))
-(assert (= 0 (log 1)))
-(assert (= 1 (exp 0)))
-(assert (= 1 (log (exp 1))))
-
-(assert-fail (acos acos))
-(assert-fail (asin asin))
-(assert-fail (atan atan))
-(assert-fail (ceiling ceiling))
-(assert-fail (cos cos))
-(assert-fail (cosh cosh))
-(assert-fail (exp exp))
-(assert-fail (expt expt expt))
-(assert-fail (floor floor))
-(assert-fail (log log))
-(assert-fail (log10 log10))
-(assert-fail (sin sin))
-(assert-fail (sinh sinh))
-(assert-fail (sqrt sqrt))
-(assert-fail (tan tan))
-(assert-fail (tanh tanh))
-
-(assert (= (length (table "hello" "goodbye" 123 456)) 2))
-(assert-fail (table 1))
-(assert-fail (table 1 2 3))
-(def ta (table 1 2 "3" 4 'foo 'bar))
-(let ((b (buffer)))
- (write ta b)
- (assert (equal? (io->str b) "#table(1 2 \"3\" 4 foo bar)")))
-(assert (table? ta))
-(assert (not (table? "nope")))
-(assert-fail (get ta 3))
-(assert-fail (get ta "foo"))
-(assert-fail (get ta 1+))
-(assert (= 2 (get ta 1)))
-(assert (= 4 (get ta "3")))
-
-(assert (has? ta 'foo))
-(assert (eq? 'bar (get ta 'foo)))
-(assert (eq? ta (del! ta 'foo)))
-(assert (not (has? ta 'foo)))
-(assert-fail (get ta 'foo))
-(assert-fail (del! ta 'foo))
-
-(assert-fail (get "blah" 0))
-(assert-fail (get (list 0 1) 0))
-
-(assert (equal? (list 1 1 1) #0=(list 1 #1=1 #1#)))
-
-(assert-fail (sleep 1 2))
-(sleep)
-(sleep 0)
-(def t₀ (nanoseconds-monotonic))
-(sleep 1)
-(def t₁ (nanoseconds-monotonic))
-(def Δt (- t₁ t₀))
-(assert (and (< Δt 1010000000 ) (> Δt 999000000)))
-(gc)
-
-(let ((ru32 (table))
- (ru64 (table))
- (rdouble (table))
- (rfloat (table)))
- (dotimes (i 100)
- (put! ru32 (rand-u32) 1)
- (put! ru64 (rand-u64) 1)
- (put! rdouble (rand-double) 1)
- (put! rfloat (rand-float) 1))
- (assert (< 50 (length ru32)))
- (assert (< 50 (length ru64)))
- (assert (< 50 (length rdouble)))
- (assert (< 50 (length rfloat))))
-
-;; auto gensym
-
-(defmacro (f x)
- `(let ((a# 1)) (list a# ,x)))
-
-(defmacro (g x)
- `(let ((a# 2)) (list a# ,x)))
-
-(assert (equal? '(1 (2 3)) (f (g 3))))
-
-(princ "all tests pass")
-(newline)
--- /dev/null
+++ b/test/unittest.sl
@@ -1,0 +1,773 @@
+(defmacro (assert-fail expr . what)
+ `(assert (trycatch (begin ,expr NIL)
+ (λ (e) ,(if (not what) t
+ `(eq? (car e) ',(car what)))))))
+
+(def (every-int n)
+ (list (fixnum n) (s8 n) (u8 n) (s16 n) (u16 n) (s32 n) (u32 n)
+ (s64 n) (u64 n) (float n) (double n) (bignum n)))
+
+(def (every-sint n)
+ (list (fixnum n) (s8 n) (s16 n) (s32 n) (s64 n) (float n) (double n) (bignum n)))
+
+(def (each f l)
+ (if (atom? l) NIL
+ (begin (f (car l))
+ (each f (cdr l)))))
+
+(def (each^2 f l m)
+ (each (λ (o) (each (λ (p) (f o p)) m)) l))
+
+(def (test-lt a b)
+ (each^2 (λ (neg pos)
+ (begin
+ (eval `(assert (= -1 (compare ,neg ,pos))))
+ (eval `(assert (= 1 (compare ,pos ,neg))))
+ (eval `(assert (< ,neg ,pos)))
+ (eval `(assert (not (< ,pos ,neg))))))
+ a
+ b))
+
+(def (test-eq a b)
+ (each^2 (λ (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))
+
+(def (test-square a)
+ (each (λ (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 INT32_MIN
+(assert (< (- #u32(0x80000000)) 0))
+(assert (> (- #s32(0x80000000)) 0))
+(assert (< (- #u64(0x8000000000000000)) 0))
+(assert (< (- #s64(0x8000000000000000)) 0))
+; fixnum versions
+(assert (= (- -536870912) 536870912))
+(assert (= (- -2305843009213693952) 2305843009213693952))
+
+(assert (not (equal? #s64(0x8000000000000000) #u64(0x8000000000000000))))
+(assert (equal? (+ #s64(0x4000000000000000) #s64(0x4000000000000000))
+ #u64(0x8000000000000000)))
+(assert (equal? (* 2 #s64(0x4000000000000000))
+ #u64(0x8000000000000000)))
+
+(assert (equal? (u64 (double -123)) #u64(0xffffffffffffff85)))
+
+(assert (equal? (str 'sym #byte(65) #rune(945) "blah") "symA\u03B1blah"))
+(assert (= (length (str #\x0)) 1))
+
+(assert (> 9223372036854775808 9223372036854775807))
+
+(assert (fixnum? (- (aref "0" 0) #\0)))
+
+(assert (= (ash #bignum(1) -9999) 0))
+
+; number boundaries
+(load "number-boundaries.sl")
+
+; bignum
+(assert (> 0x10000000000000000 0x8fffffffffffffff))
+(assert (< 0x8fffffffffffffff 0x10000000000000000))
+
+(assert (bignum? (ash 2 60)))
+(def (bignum-on-32? x) (if #.(fixnum? 0xffffffff) (not (bignum? x)) (bignum? x)))
+(assert (bignum-on-32? (- (ash 2 60) 1)))
+(assert (bignum? 1606938044258990275541962092341162602522202993782792835301376))
+(assert (bignum? 0xfffffffffffffffff))
+(assert (bignum-on-32? 0xfffffffffffffff))
+
+(assert (= 4764984380238568507752444984131552966909
+ (* 66405897020462343733 71755440315342536873)))
+(assert (= 71755440315342536873
+ (div 4764984380238568507752444984131552966909 66405897020462343733)))
+(assert (= 3203431780337 (div 576460752303423487 179951)))
+(assert (= 3487 (mod 576460752303423487 18000)))
+(assert (= 7 (mod 576460752303423487 10)))
+
+(assert (= 0xfffffffffffffffff (logior 0xaaaaaaaaaaaaaaaaa 0x55555555555555555)))
+(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
+(assert (= 0xaaaaaaaaaaaaaaaaa (logxor 0xfffffffffffffffff 0x55555555555555555)))
+(assert (= 0xaaaaaaaaa (logand 0xaaaaaaaaaaaaaaaaa 0x55555555fffffffff)))
+(assert (= 0 (logand 0 0x55555555555555555)))
+(assert (= 602394779747 (ash 11112222333344445555666677778888 -64)))
+(assert (= 204984321473364576635441321909950327706185271083008
+ (ash 11112222333344445555666677778888 64)))
+
+; NaNs
+(assert (nan? +nan.0))
+(assert (nan? -nan.0))
+(assert (nan? (float +nan.0)))
+(assert (nan? (float -nan.0)))
+(assert (equal? +nan.0 +nan.0))
+(assert (equal? -nan.0 -nan.0))
+(assert (equal? (float +nan.0) (float +nan.0)))
+(assert (equal? (float -nan.0) (float -nan.0)))
+(assert (/= +nan.0 +nan.0))
+(assert (/= +nan.0 -nan.0))
+(assert (/= -nan.0 -nan.0))
+(assert (/= (float +nan.0) (float +nan.0)))
+(assert (/= (float +nan.0) (float -nan.0)))
+(assert (/= (float -nan.0) (float -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)))
+(assert (not (<= -nan.0 -nan.0)))
+(assert (not (>= (float +nan.0) (float +nan.0))))
+(assert (not (<= (float -nan.0) (float -nan.0))))
+
+; comparing strings
+(assert (< "a" "b"))
+(assert (< "a" "b" "c"))
+(assert (> "b" "a"))
+(assert (> "c" "b" "a"))
+(assert (not (< "a" "a")))
+(assert (not (< "a" "a" "a")))
+(assert (<= "a" "a"))
+(assert (<= "a" "a" "a"))
+(assert (>= "a" "a"))
+(assert (>= "a" "a" "a"))
+(assert (>= "ab" "aa"))
+(assert (>= "ab" "aa" "aa"))
+
+; one or more than two arguments
+(assert (and (> 0) (< 0) (>= 0) (<= 0)))
+(assert (and (> 2 1 0) (< 0 1 2) (>= 2 1 0) (<= 0 1 2)))
+(assert (and (>= 2 1 1) (<= 1 1 2)))
+(assert (not (and (>= 2 1 2) (<= 2 1 2))))
+
+; comparing numbers and runes
+(assert (< 9 #\newline))
+(assert (not (< 10 #\newline)))
+(assert (= 10 #\newline))
+(assert (> 11 #\newline))
+
+; -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))
+; same but float
+(assert (not (equal? 0.0f 0)))
+(assert (equal? 0.0f 0.0f))
+(assert (not (equal? -0.0f 0.0f)))
+(assert (not (equal? -0.0f 0)))
+(assert (not (eqv? 0.0f 0)))
+(assert (not (eqv? -0.0f 0)))
+(assert (not (eqv? -0.0f 0.0f)))
+(assert (= 0.0f -0.0f))
+
+; this crashed once
+(for 1 10 (λ (i) 0))
+
+; and, or
+(assert (equal? T (and)))
+(assert (equal? NIL (or)))
+(assert (equal? 1 (and '(1) 'x 1)))
+(assert (equal? 1 (or NIL NIL NIL NIL NIL 1 NIL NIL NIL NIL)))
+(assert (equal? 2 (if (and '(1) 'x 1) 2 0)))
+(assert (equal? 2 (if (or NIL NIL NIL NIL NIL 1 NIL NIL NIL NIL) 2 0)))
+(assert (equal? NIL (and '(1) 1 'x NIL)))
+(assert (equal? NIL (or NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)))
+(assert (equal? 0 (if (and '(1) 1 'x NIL) 2 0)))
+(assert (equal? 0 (if (or NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) 2 0)))
+
+; failing applications
+(assert-fail ((λ (x) x) 1 2))
+(assert-fail ((λ (x) x)))
+(assert-fail ((λ (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))
+(def ones (map (λ (x) 1) (iota 80000)))
+(assert (= (eval `(if (< 2 1)
+ (+ ,@ones)
+ (+ ,@(cdr ones))))
+ 79999))
+
+(def MAX_ARGS 255)
+
+(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 1))))
+(def f (compile `(λ ,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))))
+
+(def as (apply list* (map-int (λ (x) (gensym)) (+ MAX_ARGS 100))))
+(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
+ ,(car (last-pair as)))))
+(assert (equal? (apply ff (iota (+ MAX_ARGS 100))) 42))
+(def ff (compile `(λ ,as (set! ,(car (last-pair as)) 42)
+ (λ () ,(car (last-pair as))))))
+(assert (equal? ((apply ff (iota (+ MAX_ARGS 100)))) 42))
+
+(def as (map-int (λ (x) (gensym)) 1000))
+(def f (compile `(λ ,as ,(car (last-pair as)))))
+(assert (equal? (apply f (iota 1000)) 999))
+
+(def as (apply list* (map-int (λ (x) (gensym)) 995)))
+(def f (compile `(λ ,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? ((λ ((b 0)) b)) 0))
+(assert (equal? ((λ (a (b 2)) (list a b)) 1) '(1 2)))
+(assert (equal? ((λ (a (b 2)) (list a b)) 1 3) '(1 3)))
+(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1) '(1 2 3)))
+(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8) '(1 8 3)))
+(assert (equal? ((λ (a (b 2) (c 3)) (list a b c)) 1 8 9) '(1 8 9)))
+(assert (equal? ((λ ((x 0) . r) (list x r))) '(0 NIL)))
+(assert (equal? ((λ ((x 0) . r) (list x r)) 1 2 3) '(1 (2 3))))
+
+; keyword arguments
+(assert (keyword? :kw))
+(assert (not (keyword? 'kw:)))
+(assert (not (keyword? 'kw)))
+(assert (not (keyword? ':)))
+(assert (equal? ((λ (x (a 2) (:b a) . r) (list x a b r)) 1 0 8 4 5)
+ '(1 0 0 (8 4 5))))
+(assert (equal? ((λ (x (a 2) (:b a) . r) (list x a b r)) 0 :b 3 1)
+ '(0 2 3 (1))))
+(def (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
+(def (keys1 (:a 8)) (+ a 1))
+(assert (equal? (keys1 :a 11) 12))
+
+; cvalues and arrays
+(assert (equal? (typeof "") '(arr byte)))
+(assert-fail (aref #(1) 3) bounds-error)
+(def iarr (arr 's64 32 16 8 7 1))
+(assert (equal? (aref iarr 0) 32))
+(assert (equal? (aref iarr #s8(3)) 7))
+
+; gensyms
+(assert (gensym? (gensym)))
+(assert (not (gensym? 'a)))
+(assert (not (eq? (gensym) (gensym))))
+(assert (not (equal? (str (gensym)) (str (gensym)))))
+(let ((gs (gensym))) (assert (eq? gs gs)))
+
+(load "color.sl")
+(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)))))
+
+(assert (let ((ts (time->str (time-now))))
+ (eqv? ts (time->str (str->time 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
+
+(def (with-output-to-str nada thunk)
+ (let ((b (buffer)))
+ (with-output-to b (thunk))
+ (io->str b)))
+
+(let ((c #\a))
+ (assert (equal? (with-output-to-str NIL (λ () (print (list c c))))
+ "(#\\a #\\a)")))
+
+(assert-fail (eval '(set! (car (cons 1 2)) 3)))
+
+(assert (equal? `(a `(b c)) '(a (quasiquote (b c)))))
+(assert (equal? ````x '```x))
+
+(assert-fail (eval '(append 1)))
+(assert-fail (eval '(append NIL 1)))
+(assert (equal? (append) NIL))
+(assert (equal? (append NIL) NIL))
+(assert (equal? (append NIL NIL) NIL))
+(assert (equal? (append '(1 2)) '(1 2)))
+(assert (equal? (append '(1 2) '(3 4)) '(1 2 3 4)))
+
+;; infinite list
+(def a '(1))
+(set-cdr! a a)
+(assert (equal? (length a) +inf.0))
+(eq? (cdr a) a)
+
+;; unbinding
+(def abc 1)
+(assert (equal? (bound? 'abc) T))
+(assert (equal? (eval '(+ abc 1)) 2))
+(makunbound 'abc)
+(assert (equal? (bound? 'abc) NIL))
+(assert-fail (eval '(+ abc 1)))
+
+;; c***r of empty list
+(assert (not (car NIL)))
+(assert (not (cdr NIL)))
+(assert (not (cadr NIL)))
+(assert (not (cdar NIL)))
+(assert (not (caaar NIL)))
+(assert (not (cdddr NIL)))
+
+;; for-each with multiple lists
+(def q NIL)
+(for-each (λ (x y) (set! q (cons (+ x y) q))) #(1 2 3) #vu8(4 5 6))
+(assert (equal? q '(9 7 5)))
+(def q 0)
+(for-each (λ (x y) (set! q (+ x y q))) '(1) '(3 9))
+(assert (equal? q 4))
+(for-each (λ (x y) (set! q (+ x y q))) '(1 2) '(3))
+(assert (equal? q 8))
+(for-each (λ (x y z) (set! q (+ x y z q))) '(1 2) '(3) '(4 5))
+(assert (equal? q 16))
+
+;; map with multiple lists
+(assert (equal? (map (λ (x y z) (+ x y z)) '(1 2 3) '(4 5 6) '(7 8 9)) '(12 15 18)))
+(assert (equal? (map (λ (x y) (+ x y)) '(1) '(3 9)) '(4)))
+(assert (equal? (map (λ (x y) (+ x y)) '(1 2) '(3)) '(4)))
+(assert (equal? (map (λ (x y z) (+ x y z)) '(1 2) '(3) '(4 5)) '(8)))
+
+;; aref with multiple indices
+(def a #(#(0 1 2) #(3 (4 5 6) 7)))
+(assert (equal? 0 (aref a 0 0)))
+(assert (equal? 0 (apply aref (list a 0 0))))
+(assert (equal? 2 (aref a 0 2)))
+(assert (equal? 3 (aref a (1+ 0) 0)))
+(assert (equal? 7 (aref a 1 2)))
+(assert (equal? 5 (aref a 1 (1+ 0) 1)))
+(assert-fail (aref a 1 1 3) bounds-error)
+(assert (equal? (fixnum #\l) (aref #("hello") 0 2)))+(assert (equal? (fixnum #\o) (aref #("hello") 0 (1+ 3))))+(assert-fail (aref #("hello") 0 5))+(assert-fail (aref #("hello") 1 0))+(assert-fail (aref '(NIL) 0 0))
+(assert-fail (apply aref '((NIL) 0 0)))
+
+;; aset with multiple indices
+(def a #(#(0 1 2) #(3 (4 5 6) 7)))
+(assert (equal? 8 (apply aset! (list a 0 0 8))))
+(assert (equal? 9 (aset! a 1 1 (1+ 1) 9)))
+(assert (equal? "hello" (aset! a (1+ 0) 2 "hello")))
+(assert-fail (aset! a 1 1 3 "nope"))
+(assert (equal? a #(#(8 1 2) #(3 (4 5 9) "hello"))))
+(assert-fail (aset! '(NIL) 0 0 1))
+(assert-fail (apply aset! '((NIL) 0 0 1)))
+
+;; apply with multiple args
+(assert (equal? 15 (apply + 1 2 '(3 4 5))))
+(assert-fail (apply + 1 2 3)) ; last arg not a list
+
+;; make many initialized tables large enough not to be stored in-line
+(for 1 100 (λ (i)
+ (table eq? 2 eqv? 2
+ equal? 2 atom? 1
+ not 1 nan? 1
+ cons? 1 sym? 1
+ num? 1 bound? 1
+ cons? 1 builtin? 1
+ vec? 1 fixnum? 1
+ cons 2 car 1
+ cdr 1 set-car! 2
+ set-cdr! 2 = 2
+ < 2 compare 2
+ aref 2 aset! 3
+ div0 2 'hello 4
+ 'goodbye 5 'foo 6
+ 'bar 7)))
+;; now allocate enough to trigger GC
+(for 1 8000000 (λ (i) (cons 1 2)))
+
+;; brieflz bindings
+(let* ((level 10)
+ (s (file "unittest.sl"))
+ (in (io-readall s))
+ (packed (lz-pack in level))
+ (unpacked (lz-unpack packed :size (sizeof in)))
+ (unpacked2 (arr-alloc 'byte (sizeof in) 0)))
+ (io-close s)
+ (assert (< (sizeof packed) (sizeof in)))
+ (assert (equal? in unpacked))
+ (assert (eq? unpacked2 (lz-unpack packed :to unpacked2)))
+ (assert (equal? in unpacked2))
+ (princ "lz packing at level " level ": " (sizeof in) " → " (sizeof packed))
+ (newline))
+
+;; macro vs function priority
+(def (!! x y) (- x y))
+(assert (eq? 3 (!! 5 2)))
+(defmacro (!! x y z) (+ z (apply !! (list x y))))
+(assert (eq? 4 (!! 5 2 1)))
+
+(def s "привет\0пока")
+(def s2 "hello \t \n world\n ")
+
+(assert (eq? 21 (sizeof s)))
+(assert (eq? 21 (length s)))
+(assert (eq? 11 (str-length s)))
+(assert (eq? 11 (str-length s 0)))
+(assert (eq? 10 (str-length s 2)))
+(assert (eq? 9 (str-length s 3)))
+(assert (eq? 0 (str-length s 21)))
+(assert-fail (str-length s -1))
+(assert-fail (str-length s 22))
+(assert (eq? 1 (str-length s 0 2)))
+(assert (eq? 2 (str-length s 0 4)))
+(assert (eq? 0 (str-length s 21 20)))
+(assert (eq? 0 (str-length s 21 21)))
+(assert-fail (str-length s 21 22))
+
+(assert (equal? "акоп\0тевирп" (str-reverse s)))
+(assert (equal? "" (str-reverse "")))
+(assert (equal? "й" (str-reverse "й")))
+(assert (equal? "wб☺🡷⁹гq" (str-reverse "qг⁹🡷☺бw")))
+
+(assert (str-utf8? ""))
+(assert (str-utf8? "wб☺🡷⁹гq"))
+(assert (not (str-utf8? "\xfffe")))
+
+(let ((b (buffer)))
+ (write "a\x0a\x09\\\x07\x08\x1b\x0c\x0d\x0b" b)
+ (assert (equal? (io->str b) "\"a\\n\\t\\\\\\a\\b\\e\\f\\r\\v\"")))
+
+(assert (= 10 (str-width s)))
+(assert (= 0 (str-width "")))
+(assert (= 1 (str-width #\q)))
+(assert (= 1 (str-width #\й)))
+(assert (= 0 (str-width #\nul)))
+(assert-fail (str-width 123))
+(assert-fail (str-width 'blah))
+(assert-fail (str-width str-width))
+
+(assert (equal? '("привет" "пока") (str-split s "\0")))+(assert (equal? '("пр" "вет" "пок" "") (str-split s "аи\0")))+(assert (equal? '("" "") (str-split "1" "1")))+
+(assert (equal? '("hello" "world") (str-split s2 :trim T)))+(assert (equal? '("hello" "\t" "\n" "world\n") (str-split s2 " " :trim T)))+(assert (equal? (list s2) (str-split s2 "X" :trim T)))
+(assert (equal? (list s2) (str-split s2 "X")))
+
+(assert (equal? #\а (str-rune s 10)))
+(assert (equal? #\nul (str-rune s 6)))
+(assert-fail (str-rune s 11))
+
+(assert (equal? #\W (rune-upcase #\w)))
+(assert (equal? #\П (rune-upcase #\п)))
+(assert (equal? #\nul (rune-upcase #\nul)))
+
+(assert (rune-upper-case? #\W))
+(assert (rune-upper-case? #\П))
+(assert (not (rune-upper-case? #\nul)))
+(assert (not (rune-upper-case? #\w)))
+(assert (not (rune-upper-case? #\п)))
+(assert (not (rune-upper-case? #\nul)))
+
+(assert (equal? #\w (rune-downcase #\W)))
+(assert (equal? #\п (rune-downcase #\П)))
+(assert (equal? #\nul (rune-downcase #\nul)))
+
+(assert (rune-lower-case? #\w))
+(assert (rune-lower-case? #\п))
+(assert (not (rune-lower-case? #\nul)))
+(assert (not (rune-lower-case? #\W)))
+(assert (not (rune-lower-case? #\П)))
+(assert (not (rune-lower-case? #\nul)))
+
+(assert (rune-numeric? #\0))
+(assert (rune-numeric? #\9))
+(assert (not (rune-numeric? #\⁰)))
+(assert (not (rune-numeric? #\q)))
+
+(assert (rune-whitespace? #\space))
+(assert (rune-whitespace? #\tab))
+(assert (rune-whitespace? #\vtab))
+(assert (rune-whitespace? #\newline))
+(assert (rune-whitespace? #\x00a0))
+(assert (rune-whitespace? #\x3000))
+(assert (not (rune-whitespace? #\x200b)))
+
+(assert (rune-alphabetic? #\q))
+(assert (rune-alphabetic? #\й))
+(assert (not (rune-alphabetic? #\⁰)))
+(assert (not (rune-alphabetic? #\0)))
+
+(assert (not (rune-title-case? #\DŽ)))
+(assert (equal? #\Dž (rune-titlecase #\DŽ)))
+(assert (rune-title-case? #\Dž))
+
+(def s "hello й goodbye")
+(assert (= 4 (str-find s #\o)))
+(assert (= 9 (str-find s #\o 5)))
+(assert (= 10 (str-find s #\o 10)))
+(assert (not (str-find s #\o 11)))
+(assert (not (str-find s #\o 15)))
+(assert (= 4 (str-find s "o")))
+(assert (= 2 (str-find s "ll")))
+(assert (not (str-find s "ll" 3)))
+(assert (= 0 (str-find s "")))
+(assert (= 7 (str-find s "" 7)))
+(assert (= 6 (str-find s #\й)))
+(assert (= 6 (str-find s #\й 6)))
+(assert-fail (str-find s #\o -1))
+(assert-fail (str-find s #\o 16))
+(assert-fail (str-find s 0))
+(assert-fail (str-find s (byte #\o)))
+
+(assert (equal? "1.5" (num->str 1.5)))
+(assert (equal? "-3039" (num->str (s16 -12345) 16)))
+(assert (equal? "111111111111111111111111111111111" (num->str 111111111111111111111111111111111)))
+(assert (equal? "fffffffffffffffffffffffffffffffff" (num->str 0xfffffffffffffffffffffffffffffffff 16)))
+
+(assert-fail (num->str 1.5 16))
+(assert-fail (num->str (bignum 0) 36))
+
+(assert (= 1.5 (str->num "1.5")))
+(assert (= -12345 (str->num "-3039" 16)))
+(assert (= 111111111111111111111111111111111 (str->num "111111111111111111111111111111111")))
+(assert (= 0xfffffffffffffffffffffffffffffffff (str->num "fffffffffffffffffffffffffffffffff" 16)))
+
+(assert (= (length (byte #\f)) 1))
+(assert (= (length #\я) 2))
+(assert (= (length #\⁹) 3))
+(assert-fail (= (length (u8 0)) 1))
+(assert-fail (= (length (u16 0)) 2))
+(assert-fail (= (length (u32 0)) 4))
+(assert-fail (= (length (u64 0)) 4))
+(assert-fail (= (length (bignum 0)) 0))
+
+(assert (eq? (sym 'blah) 'blah))
+(assert (eq? (sym "hi" "there" 'symbol 123) 'hitheresymbol123))
+
+(assert-fail (exit "error" 2))
+
+(assert (int-valued? 1.0))
+(assert (int-valued? -1.0))
+(assert (int-valued? 1.0f))
+(assert (int-valued? -1.0f))
+(assert (int-valued? (bignum 0)))
+
+(assert (num? 1.3))
+(assert (num? -1.3))
+(assert (num? 1.3f))
+(assert (num? -1.3f))
+(assert (not (num? #\я)))
+
+(assert (int? 0))
+(assert (int? (bignum 0)))
+
+(assert (= 12345 (fixnum (bignum 12345))))
+(assert (= -12345 (fixnum (bignum -12345))))
+
+(assert (= 1.0 (truncate 1.3)))
+(assert (= -1.0 (truncate -1.3)))
+(assert (= 1.0 (truncate 1.3)))
+(assert (= -1.0 (truncate -1.3)))
+(assert (= 1.0 (truncate 1.3f)))
+(assert (= -1.0 (truncate -1.3f)))
+(assert (= 1.0 (truncate 1.3f)))
+(assert (= -1.0 (truncate -1.3f)))
+(assert (= 1 (truncate (bignum 1))))
+(assert (= -1 (truncate (bignum -1))))
+(assert (= 123 (truncate (s64 123))))
+(assert (= -123 (truncate (s8 -123))))
+(assert-fail (truncate "blah"))
+(assert-fail (truncate 'blah))
+(assert-fail (truncate truncate))
+
+(assert (= 0 (sin 0)))
+(assert (= 0 (sin 0.0)))
+(assert (= 0 (sin 0.0f)))
+(assert (= 0 (sin (s64 0))))
+(assert (= 0 (sin (bignum 0))))
+(let ((x (cos 0)))
+ (assert (and (>= x 0.999999999999999) (<= x 1.0))))
+(assert (= 3 (sqrt 9)))
+(assert (= 3 (log10 1000)))
+(assert (= 0 (log 1)))
+(assert (= 1 (exp 0)))
+(assert (= 1 (log (exp 1))))
+
+(assert-fail (acos acos))
+(assert-fail (asin asin))
+(assert-fail (atan atan))
+(assert-fail (ceiling ceiling))
+(assert-fail (cos cos))
+(assert-fail (cosh cosh))
+(assert-fail (exp exp))
+(assert-fail (expt expt expt))
+(assert-fail (floor floor))
+(assert-fail (log log))
+(assert-fail (log10 log10))
+(assert-fail (sin sin))
+(assert-fail (sinh sinh))
+(assert-fail (sqrt sqrt))
+(assert-fail (tan tan))
+(assert-fail (tanh tanh))
+
+(assert (= (length (table "hello" "goodbye" 123 456)) 2))
+(assert-fail (table 1))
+(assert-fail (table 1 2 3))
+(def ta (table 1 2 "3" 4 'foo 'bar))
+(let ((b (buffer)))
+ (write ta b)
+ (assert (equal? (io->str b) "#table(1 2 \"3\" 4 foo bar)")))
+(assert (table? ta))
+(assert (not (table? "nope")))
+(assert-fail (get ta 3))
+(assert-fail (get ta "foo"))
+(assert-fail (get ta 1+))
+(assert (= 2 (get ta 1)))
+(assert (= 4 (get ta "3")))
+
+(assert (has? ta 'foo))
+(assert (eq? 'bar (get ta 'foo)))
+(assert (eq? ta (del! ta 'foo)))
+(assert (not (has? ta 'foo)))
+(assert-fail (get ta 'foo))
+(assert-fail (del! ta 'foo))
+
+(assert-fail (get "blah" 0))
+(assert-fail (get (list 0 1) 0))
+
+(assert (equal? (list 1 1 1) #0=(list 1 #1=1 #1#)))
+
+(assert-fail (sleep 1 2))
+(sleep)
+(sleep 0)
+(def t₀ (nanoseconds-monotonic))
+(sleep 1)
+(def t₁ (nanoseconds-monotonic))
+(def Δt (- t₁ t₀))
+(assert (and (< Δt 1010000000 ) (> Δt 999000000)))
+(gc)
+
+(let ((ru32 (table))
+ (ru64 (table))
+ (rdouble (table))
+ (rfloat (table)))
+ (dotimes (i 100)
+ (put! ru32 (rand-u32) 1)
+ (put! ru64 (rand-u64) 1)
+ (put! rdouble (rand-double) 1)
+ (put! rfloat (rand-float) 1))
+ (assert (< 50 (length ru32)))
+ (assert (< 50 (length ru64)))
+ (assert (< 50 (length rdouble)))
+ (assert (< 50 (length rfloat))))
+
+;; auto gensym
+
+(defmacro (f x)
+ `(let ((a# 1)) (list a# ,x)))
+
+(defmacro (g x)
+ `(let ((a# 2)) (list a# ,x)))
+
+(assert (equal? '(1 (2 3)) (f (g 3))))
+
+(princ "all tests pass")
+(newline)
--- a/tools/bootstrap.sh
+++ b/tools/bootstrap.sh
@@ -5,10 +5,10 @@
test -x $F || { meson setup -Dbuildtype=debug build . && ninja -C build || exit 1; } test -x $F || { echo no $F found; exit 1; }cd src && \
-$F ../tools/gen.lsp && \
+$F ../tools/gen.sl && \
cp ../boot/sl.boot ../boot/sl.boot.bak && \
-$F ../tools/mkboot0.lsp builtins.lsp instructions.lsp system.lsp compiler.lsp > ../boot/sl.boot && \
+$F ../tools/mkboot0.sl builtins.sl instructions.sl system.sl compiler.sl > ../boot/sl.boot && \
ninja -C ../build && \
cd ../boot && \
-$F ../tools/mkboot1.lsp && \
+$F ../tools/mkboot1.sl && \
ninja -C ../build || { cp "$P/boot/sl.boot.bak" "$P/boot/sl.boot"; exit 1; }--- a/tools/disenv.lsp
+++ /dev/null
@@ -1,10 +1,0 @@
-#!/usr/bin/env sl
-(for-each (lambda (e)
- (let ((v (top-level-value e)))
- (when (and (fn? v)
- (not (builtin? v)))
- (print e)
- (newline)
- (fn-disasm v)
- (newline))))
- (environment))
--- /dev/null
+++ b/tools/disenv.sl
@@ -1,0 +1,10 @@
+#!/usr/bin/env sl
+(for-each (lambda (e)
+ (let ((v (top-level-value e)))
+ (when (and (fn? v)
+ (not (builtin? v)))
+ (print e)
+ (newline)
+ (fn-disasm v)
+ (newline))))
+ (environment))
--- a/tools/gen.lsp
+++ /dev/null
@@ -1,461 +1,0 @@
-(defstruct op name cname nargs closure docs)
-
-(def (rune-alphanumeric? r)
- (or (rune-alphabetic? r)
- (rune-numeric? r)))
-
-(def (name->cname name)
- (let {[cname (buffer)]}- (for 0 (1- (length name))
- (λ (i) (let {[r (rune (aref name i))]}- (io-write cname
- (cond [(rune-alphanumeric? r) (rune-upcase r)]
- [(= r #\?) #\P]
- [(= r #\_) #\_]
- [else ""])))))
- (io->str cname)))
-
-(defmacro (op symbol (nargs NIL) (closure NIL) (docs NIL) (:cname NIL))
- (let ((name (str symbol)))
- `(make-op :name ,name
- :cname ,(str "OP_" (or cname (name->cname name)))
- :nargs ,nargs
- :closure ',closure
- :docs ',docs)))
-
-(def ops (vec
- (op loada0)
- (op loada1)
- (op loadv)
- (op brn)
- (op pop)
- (op call)
- (op tcall)
- (op loadg)
- (op loada)
- (op loadc)
- (op ret)
- (op dup)
- (op car 1 (λ (x) (car x))
- {[(lst)- "Return the first element of a cons cell (head of a list) or `NIL` if
- not available.
-
- Examples:
-
- (car NIL) → NIL
- (car '(1 2 3)) → 1
- (car '(1 . 2)) → 1"]})
- (op cdr 1 (λ (x) (cdr x))
- {[(lst)- "Return the second element of a cons cell (tail of a list) or `NIL` if
- not available.
-
- Examples:
-
- (cdr NIL) → NIL
- (cdr '(1 2 3)) → (2 3)
- (cdr '(1 . 2)) → 2"]})
- (op closure)
- (op seta)
- (op jmp)
- (op loadc0)
- (op cons? 1 (λ (x) (cons? x))
- {[(v)- "Return `T` if `v` is a cons cell, `NIL` otherwise.
-
- Examples:
-
- (cons? 0) → NIL
- (cons? NIL) → NIL
- (cons? '(1)) → T"]})
- (op brne)
- (op loadt)
- (op load0)
- (op loadc1)
- (op aref2)
- (op atom? 1 (λ (x) (atom? x))
- {[(value)- "Return `T` if `v` is a _not_ a cons cell, `NIL` otherwise. This is
- the opposite of `cons?`.
-
- The term \"atom\" comes from the idea of being indivisible.
-
- Examples:
-
- (atom? \"a\") → T
- (atom? NIL) → T
- (atom? '(1)) → NIL"]})
- (op loadvoid)
- (op brnn)
- (op load1)
- (op < -1 (λ rest (apply < rest))
- {[(a . rest)- "Return `T` if the arguments are in strictly increasing order (next
- one is greater than the previous one). With a single argument
- the result is always `T`."]}
- :cname "LT")
- (op add2)
- (op set-cdr! 2 (λ (x y) (set-cdr! x y))
- {[(cell new-second)- "Modify a cons cell (a list) in-place by putting `new-second` as its
- second element (tail of the list). Return the modified cons
- cell (list).
-
- Examples:
-
- (def q '(1 2 3 4 5))
- (set-cdr! q '(6 7)) → (1 6 7)
- q → (1 6 7)"]})
- (op keyargs)
- (op cons 2 (λ (x y) (cons x y))
- {[(first second)- "Return a cons cell containing two arguments.
-
- Examples:
-
- (cons 1 2) → (1 . 2)
- (cons 1 '(2)) → (1 2)
- (cons 1 (cons 2 (cons 3 NIL))) → (1 2 3)"]})
- (op eq? 2 (λ (x y) (eq? x y))
- {[(a b)- "Return `T` if `a` and `b` are the same object, `NIL` otherwise.
-
- Examples:
-
- (eq? 0.0 0) → NIL
- (eq? 0 0) → T
- (def a \"1\")
- (def b \"1\")
- (eq? a b) → NIL
- (def a '(1))
- (def b '(1))
- (eq? a b) → NIL"]})
- (op sym? 1 (λ (x) (sym? x))
- {[(v)- "Return `T` if `v` is a symbol, `NIL` otherwise."]})
- (op not 1 (λ (x) (not x))
- {[(v)- "Return `T` if `v` is `NIL`, `T` otherwise."]})
- (op cadr 1 (λ (x) (cadr x))
- {[(cell)- "Shorthand for `(car (cdr cell))`, that is, \"first element of the
- second element\".
-
- Examples:
-
- (cadr '(1 2 3)) → 2
- (cadr '(1)) → NIL
- (cadr NIL) → NIL"]})
- (op neg)
- (op nan? 1 (λ (x) (nan? x))
- {[(v)- "Return `T` if `v` is a floating point representation of NaN, either
- negative or positive, `NIL` otherwise."]})
- (op brbound)
- (op num? 1 (λ (x) (num? x))
- {[(v)- "Return `T` if `v` is of a numerical type, `NIL` otherwise.
-
- Numerical types include floating point, fixnum, bignum, etc.
- Note: ironically, a NaN value is considered a number by this function
- since it's only testing the _type_ of the value."]})
- (op fixnum? 1 (λ (x) (fixnum? x))
- {[(v)- "Return `T` if `v` is of a fixnum type, `NIL` otherwise."]})
- (op bound? 1 (λ (x) (bound? x))
- {[(symbol)- "Return `T` if `symbol` has a value associated with it, `NIL` otherwise."]})
- (op builtin? 1 (λ (x) (builtin? x))
- {[(v)- "Return `T` if `v` is a built-in function implemented in C, `NIL`
- otherwise.
-
- Examples:
-
- (builtin? map) → T
- (builtin? macroexpand) → NIL"]})
- (op fn? 1 (λ (x) (fn? x))
- {[(v)- "Return `T` if `v` is a function, `NIL` otherwise.
-
- Examples:
-
- (fn? map) → T
- (fn? macroexpand) → T"]})
- (op vec? 1 (λ (x) (vec? x))
- {[(v)- "Return `T` if `v` is a vector, `NIL` otherwise."]})
- (op shift)
- (op set-car! 2 (λ (x y) (set-car! x y))
- {[(cell new-first)- "Modify a cons cell (a list) in-place by putting `new-first` as its
- first element (head of the list). Return the modified cons
- cell (list).
-
- Examples:
-
- (def q '(1 2 3 4 5))
- (set-car! q 0) → (0 6 7)
- q → (0 6 7)"]})
- (op jmp.l)
- (op brn.l)
- (op box)
- (op eqv? 2 (λ (x y) (eqv? x y))
- {[(a b)- "Return `T` if both `a` and `b` are of the same value and primitive
- (leaf) type, `NIL` otherwise. Neither cons cell nor vector are not
- considered primitive types as they may define deep structures.
-
- Examples:
-
- (eqv? 0.0 0) → NIL
- (eqv? 0 0) → T
- (def a \"1\")
- (def b \"1\")
- (eqv? a b) → T
- (def a '(1))
- (def b '(1))
- (eqv? a b) → NIL"]})
- (op equal? 2 (λ (x y) (equal? x y))
- {[(a b)- "Return `T` if both `a` and `b` are of the same value. For non-leaf
- types (cons cell and vector), the equality test is performed
- throughout the whole structure of the values.
-
- Examples:
-
- (equal? 0.0 0) → NIL
- (equal? 0 0) → T
- (def a \"1\")
- (def b \"1\")
- (equal? a b) → T
- (def a '(1))
- (def b '(1))
- (equal? a b) → T"]})
- (op list T (λ rest rest)
- {[rest- "Return a list constructed of the arguments.
-
- Examples:
-
- (list) → NIL ; empty list
- (list 1 2.5 \"a\" 'b) → (1 2.5 \"a\" b)"]})
- (op apply -2 (λ rest (apply apply rest))
- {[(fn arg . rest)- "Return the result of applying a function to a list of arguments.
-
- The last argument must always be a list which gets spliced as
- arguments to the function.
-
- Examples:
-
- (apply + 1 2 '(3 4 5)) → 15
- (apply vec '(1 2 3)) → #(3 4 5)
- (apply arr 'u8 '(3 4 5)) → #vu8(3 4 5)"]})
- (op + T (λ rest (apply + rest))
- {[rest- "Return sum of the arguments or `0` when none specified."]}
- :cname "ADD")
- (op - -1 (λ rest (apply - rest))
- {[(a . rest)- "Return the result of subtraction. With only one argument a
- negation is performed.
-
- Examples:
-
- (- 1.5) → -1.5
- (- 3 2) → 1"]}
- :cname "SUB")
- (op * T (λ rest (apply * rest))
- {[rest- "Return product of the arguments or `1` when none specified."]}
- :cname "MUL")
- (op / -1 (λ rest (apply / rest))
- {[(x . rest)- "Return the division of the arguments. With only one argument the
- result of `1/x` is returned. If the result is integer-valued, it is
- returned as an integer.
-
- Examples:
-
- (/ 2) → 0.5
- (/ 7 2 2) → 1.75
- (/ 10 -2) → -5 ; a fixnum
- (/ 6.9 1.9) → 3.6315…"]}
- :cname "DIV")
- (op div0 2 (λ rest (apply div0 rest))
- {[(a b)- "Return the quotient of two numbers. For non-integers this is
- equivalent to `(div0 (floor a) (floor b))`. The result is always an
- integer.
-
- Examples:
-
- (div0 7 2) → 3
- (div0 10 -2) → -5
- (div0 6.9 1.9) → 6"]})
- (op = -1 (λ rest (apply = rest))
- {[(a . rest)- "Numerical equality test. Return `T` if all numbers are equal,
- `NIL` otherwise."]}
- :cname "NUMEQP")
- (op compare 2 (λ (x y) (compare x y))
- {[(x y)- "Return -1 if `x` is less than `y`, 0 if equal, and `1` if `y` is
- greater than `x`.
-
- Examples:
-
- (compare 'a 'b) → -1
- (compare 1 1) → 0
- (compare \"b\" \"a\") → 1"]})
- (op argc)
- (op vec T (λ rest (apply vec rest))
- {[rest- "Return a vector constructed of the arguments.
-
- Examples:
-
- (vec) → #() ; empty vector
- (vec 1 2.5 \"a\" 'b) → #(1 2.5 \"a\" b)"]})
- (op aset! -3 (λ rest (apply aset! rest))
- {[(sequence subscripts… new-value)- "Modify the sequence element specified by the subscripts and return the
- new value. The sequence can be an array, vector, a list.
- Multi-dimensional sequences of variating types are also supported.
-
- Examples:
-
- (def a '((1 #(2 (3)) 4)))
- (aset! a 1 'x) → index 1 out of bounds
- (aset! a 0 0 'x) → x
- a → ((x #(2 (3)) 4))
- (aset! a 0 1 9) → 9
- a → ((x #(9 (3)) 4))"]})
- (op loadnil)
- (op loadi8)
- (op loadv.l)
- (op loadg.l)
- (op loada.l)
- (op loadc.l)
- (op setg)
- (op setg.l)
- (op seta.l)
- (op vargc)
- (op trycatch)
- (op for 3 (λ (a b f) (for a b (λ (x) (f x))))
- {[(min max fn)- "Call the function `fn` with a single integer argument, starting from
- `min` and ending with `max`.
-
- Examples:
-
- (for 0 2 (λ (i) (print (- 2 i)))) → 210"]})
- (op tapply)
- (op sub2)
- (op argc.l)
- (op vargc.l)
- (op call.l)
- (op tcall.l)
- (op brne.l)
- (op brnn.l)
- (op aref -2 (λ rest (apply aref rest))
- {[(sequence subscript0 . rest)- "Return the sequence element specified by the subscripts. The sequence
- can be an array, vector, a list. Multi-dimensional sequences
- of variating types are also supported.
-
- Examples:
-
- (def a '((1 #(2 (3)) 4)))
- (aref a 0) → (1 (2 (3)) 4)
- (aref a 1) → index 1 out of bounds
- (aref a 0 0) → 1
- (aref a 0 1 0) → 2
- (aref a 0 2) → 4"]})
- (op box.l)
- (op optargs)
- (op dummy_eof)
-))
-
-(def (new path)
- (file path :write :create :truncate))
-
-(let ((c-header (buffer)) ; to avoid broken code truncating valid files
- (c-code (buffer))
- (instructions (new "instructions.lsp"))
- (builtins (new "builtins.lsp"))
- (docs-ops (new "docs_ops.lsp"))
- (op-to-byte (table))
- (c-op-to-op-arg (table))
- (op-to-argc (table))
- (op-to-closure ())
- (i 0))
- (io-write c-header "typedef enum {\n")- (for-each
- (λ (op)
- (let {[lop (sym (op-name op))]- [argc (op-nargs op)]}
- (io-write c-header (str "\t" (op-cname op) ",\n"))
- (for-each (λ (doc)
- (let* {[args (car doc)]- [sig (cons lop args)]
- [docargs (cdr doc)]
- [docstr (car docargs)]}
- (unless (str? docstr)
- (error lop ": documentation must be a string"))
- (unless (or (sym? sig) (cons? sig))
- (error lop ": invalid signature"))
- (write `(doc-for ,sig ,@docargs) docs-ops)
- (newline docs-ops)))
- (op-docs op))
- (put! op-to-byte lop (byte i))
- (when argc
- (put! c-op-to-op-arg (op-cname op) (list lop (if (eq? argc T) 'ANYARGS argc)))
- (when (and (num? argc) (>= argc 0))
- (put! op-to-argc lop argc)))
- (set! op-to-closure (cons (op-closure op) op-to-closure))
- (set! i (1+ i))))
- ops)
- (io-close docs-ops)
- (io-write c-header "\tN_OPCODES\n}sl_op;\n\n")
- (io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
-
- (io-write c-code "#include \"sl.h\"\n\n")
- (io-write c-code "const Builtin builtins[N_OPCODES] = {\n")- (for-each
- (λ (c la) (begin (io-write c-code (str "\t[" c))
- (io-write c-code "] = {\"")- (write (car la) c-code)
- (io-write c-code "\", ")
- (write (cadr la) c-code)
- (io-write c-code "},\n")))
- c-op-to-op-arg)
- (io-write c-code "};\n")
-
- (write `(def Instructions
- "VM instructions mapped to their encoded byte representation."
- ,op-to-byte)
- instructions)
- (newline instructions)
- (newline instructions)
- (write `(def arg-counts
- "VM instructions mapped to their expected arguments count."
- ,op-to-argc)
- instructions)
- (newline instructions)
- (io-close instructions)
- (set! op-to-closure (cons vec (reverse! op-to-closure)))
- (write `(def *builtins*
- "VM instructions as closures."
- ,op-to-closure)
- builtins)
- (newline builtins)
- (io-close builtins)
-
- ;; at last, copy the buffers to the actual files in git repo.
- (io-seek c-header 0)
- (io-copy (new "opcodes.h") c-header)
- (io-seek c-code 0)
- (io-copy (new "opcodes.c") c-code))
--- /dev/null
+++ b/tools/gen.sl
@@ -1,0 +1,461 @@
+(defstruct op name cname nargs closure docs)
+
+(def (rune-alphanumeric? r)
+ (or (rune-alphabetic? r)
+ (rune-numeric? r)))
+
+(def (name->cname name)
+ (let {[cname (buffer)]}+ (for 0 (1- (length name))
+ (λ (i) (let {[r (rune (aref name i))]}+ (io-write cname
+ (cond [(rune-alphanumeric? r) (rune-upcase r)]
+ [(= r #\?) #\P]
+ [(= r #\_) #\_]
+ [else ""])))))
+ (io->str cname)))
+
+(defmacro (op symbol (nargs NIL) (closure NIL) (docs NIL) (:cname NIL))
+ (let ((name (str symbol)))
+ `(make-op :name ,name
+ :cname ,(str "OP_" (or cname (name->cname name)))
+ :nargs ,nargs
+ :closure ',closure
+ :docs ',docs)))
+
+(def ops (vec
+ (op loada0)
+ (op loada1)
+ (op loadv)
+ (op brn)
+ (op pop)
+ (op call)
+ (op tcall)
+ (op loadg)
+ (op loada)
+ (op loadc)
+ (op ret)
+ (op dup)
+ (op car 1 (λ (x) (car x))
+ {[(lst)+ "Return the first element of a cons cell (head of a list) or `NIL` if
+ not available.
+
+ Examples:
+
+ (car NIL) → NIL
+ (car '(1 2 3)) → 1
+ (car '(1 . 2)) → 1"]})
+ (op cdr 1 (λ (x) (cdr x))
+ {[(lst)+ "Return the second element of a cons cell (tail of a list) or `NIL` if
+ not available.
+
+ Examples:
+
+ (cdr NIL) → NIL
+ (cdr '(1 2 3)) → (2 3)
+ (cdr '(1 . 2)) → 2"]})
+ (op closure)
+ (op seta)
+ (op jmp)
+ (op loadc0)
+ (op cons? 1 (λ (x) (cons? x))
+ {[(v)+ "Return `T` if `v` is a cons cell, `NIL` otherwise.
+
+ Examples:
+
+ (cons? 0) → NIL
+ (cons? NIL) → NIL
+ (cons? '(1)) → T"]})
+ (op brne)
+ (op loadt)
+ (op load0)
+ (op loadc1)
+ (op aref2)
+ (op atom? 1 (λ (x) (atom? x))
+ {[(value)+ "Return `T` if `v` is a _not_ a cons cell, `NIL` otherwise. This is
+ the opposite of `cons?`.
+
+ The term \"atom\" comes from the idea of being indivisible.
+
+ Examples:
+
+ (atom? \"a\") → T
+ (atom? NIL) → T
+ (atom? '(1)) → NIL"]})
+ (op loadvoid)
+ (op brnn)
+ (op load1)
+ (op < -1 (λ rest (apply < rest))
+ {[(a . rest)+ "Return `T` if the arguments are in strictly increasing order (next
+ one is greater than the previous one). With a single argument
+ the result is always `T`."]}
+ :cname "LT")
+ (op add2)
+ (op set-cdr! 2 (λ (x y) (set-cdr! x y))
+ {[(cell new-second)+ "Modify a cons cell (a list) in-place by putting `new-second` as its
+ second element (tail of the list). Return the modified cons
+ cell (list).
+
+ Examples:
+
+ (def q '(1 2 3 4 5))
+ (set-cdr! q '(6 7)) → (1 6 7)
+ q → (1 6 7)"]})
+ (op keyargs)
+ (op cons 2 (λ (x y) (cons x y))
+ {[(first second)+ "Return a cons cell containing two arguments.
+
+ Examples:
+
+ (cons 1 2) → (1 . 2)
+ (cons 1 '(2)) → (1 2)
+ (cons 1 (cons 2 (cons 3 NIL))) → (1 2 3)"]})
+ (op eq? 2 (λ (x y) (eq? x y))
+ {[(a b)+ "Return `T` if `a` and `b` are the same object, `NIL` otherwise.
+
+ Examples:
+
+ (eq? 0.0 0) → NIL
+ (eq? 0 0) → T
+ (def a \"1\")
+ (def b \"1\")
+ (eq? a b) → NIL
+ (def a '(1))
+ (def b '(1))
+ (eq? a b) → NIL"]})
+ (op sym? 1 (λ (x) (sym? x))
+ {[(v)+ "Return `T` if `v` is a symbol, `NIL` otherwise."]})
+ (op not 1 (λ (x) (not x))
+ {[(v)+ "Return `T` if `v` is `NIL`, `T` otherwise."]})
+ (op cadr 1 (λ (x) (cadr x))
+ {[(cell)+ "Shorthand for `(car (cdr cell))`, that is, \"first element of the
+ second element\".
+
+ Examples:
+
+ (cadr '(1 2 3)) → 2
+ (cadr '(1)) → NIL
+ (cadr NIL) → NIL"]})
+ (op neg)
+ (op nan? 1 (λ (x) (nan? x))
+ {[(v)+ "Return `T` if `v` is a floating point representation of NaN, either
+ negative or positive, `NIL` otherwise."]})
+ (op brbound)
+ (op num? 1 (λ (x) (num? x))
+ {[(v)+ "Return `T` if `v` is of a numerical type, `NIL` otherwise.
+
+ Numerical types include floating point, fixnum, bignum, etc.
+ Note: ironically, a NaN value is considered a number by this function
+ since it's only testing the _type_ of the value."]})
+ (op fixnum? 1 (λ (x) (fixnum? x))
+ {[(v)+ "Return `T` if `v` is of a fixnum type, `NIL` otherwise."]})
+ (op bound? 1 (λ (x) (bound? x))
+ {[(symbol)+ "Return `T` if `symbol` has a value associated with it, `NIL` otherwise."]})
+ (op builtin? 1 (λ (x) (builtin? x))
+ {[(v)+ "Return `T` if `v` is a built-in function implemented in C, `NIL`
+ otherwise.
+
+ Examples:
+
+ (builtin? map) → T
+ (builtin? macroexpand) → NIL"]})
+ (op fn? 1 (λ (x) (fn? x))
+ {[(v)+ "Return `T` if `v` is a function, `NIL` otherwise.
+
+ Examples:
+
+ (fn? map) → T
+ (fn? macroexpand) → T"]})
+ (op vec? 1 (λ (x) (vec? x))
+ {[(v)+ "Return `T` if `v` is a vector, `NIL` otherwise."]})
+ (op shift)
+ (op set-car! 2 (λ (x y) (set-car! x y))
+ {[(cell new-first)+ "Modify a cons cell (a list) in-place by putting `new-first` as its
+ first element (head of the list). Return the modified cons
+ cell (list).
+
+ Examples:
+
+ (def q '(1 2 3 4 5))
+ (set-car! q 0) → (0 6 7)
+ q → (0 6 7)"]})
+ (op jmp.l)
+ (op brn.l)
+ (op box)
+ (op eqv? 2 (λ (x y) (eqv? x y))
+ {[(a b)+ "Return `T` if both `a` and `b` are of the same value and primitive
+ (leaf) type, `NIL` otherwise. Neither cons cell nor vector are not
+ considered primitive types as they may define deep structures.
+
+ Examples:
+
+ (eqv? 0.0 0) → NIL
+ (eqv? 0 0) → T
+ (def a \"1\")
+ (def b \"1\")
+ (eqv? a b) → T
+ (def a '(1))
+ (def b '(1))
+ (eqv? a b) → NIL"]})
+ (op equal? 2 (λ (x y) (equal? x y))
+ {[(a b)+ "Return `T` if both `a` and `b` are of the same value. For non-leaf
+ types (cons cell and vector), the equality test is performed
+ throughout the whole structure of the values.
+
+ Examples:
+
+ (equal? 0.0 0) → NIL
+ (equal? 0 0) → T
+ (def a \"1\")
+ (def b \"1\")
+ (equal? a b) → T
+ (def a '(1))
+ (def b '(1))
+ (equal? a b) → T"]})
+ (op list T (λ rest rest)
+ {[rest+ "Return a list constructed of the arguments.
+
+ Examples:
+
+ (list) → NIL ; empty list
+ (list 1 2.5 \"a\" 'b) → (1 2.5 \"a\" b)"]})
+ (op apply -2 (λ rest (apply apply rest))
+ {[(fn arg . rest)+ "Return the result of applying a function to a list of arguments.
+
+ The last argument must always be a list which gets spliced as
+ arguments to the function.
+
+ Examples:
+
+ (apply + 1 2 '(3 4 5)) → 15
+ (apply vec '(1 2 3)) → #(3 4 5)
+ (apply arr 'u8 '(3 4 5)) → #vu8(3 4 5)"]})
+ (op + T (λ rest (apply + rest))
+ {[rest+ "Return sum of the arguments or `0` when none specified."]}
+ :cname "ADD")
+ (op - -1 (λ rest (apply - rest))
+ {[(a . rest)+ "Return the result of subtraction. With only one argument a
+ negation is performed.
+
+ Examples:
+
+ (- 1.5) → -1.5
+ (- 3 2) → 1"]}
+ :cname "SUB")
+ (op * T (λ rest (apply * rest))
+ {[rest+ "Return product of the arguments or `1` when none specified."]}
+ :cname "MUL")
+ (op / -1 (λ rest (apply / rest))
+ {[(x . rest)+ "Return the division of the arguments. With only one argument the
+ result of `1/x` is returned. If the result is integer-valued, it is
+ returned as an integer.
+
+ Examples:
+
+ (/ 2) → 0.5
+ (/ 7 2 2) → 1.75
+ (/ 10 -2) → -5 ; a fixnum
+ (/ 6.9 1.9) → 3.6315…"]}
+ :cname "DIV")
+ (op div0 2 (λ rest (apply div0 rest))
+ {[(a b)+ "Return the quotient of two numbers. For non-integers this is
+ equivalent to `(div0 (floor a) (floor b))`. The result is always an
+ integer.
+
+ Examples:
+
+ (div0 7 2) → 3
+ (div0 10 -2) → -5
+ (div0 6.9 1.9) → 6"]})
+ (op = -1 (λ rest (apply = rest))
+ {[(a . rest)+ "Numerical equality test. Return `T` if all numbers are equal,
+ `NIL` otherwise."]}
+ :cname "NUMEQP")
+ (op compare 2 (λ (x y) (compare x y))
+ {[(x y)+ "Return -1 if `x` is less than `y`, 0 if equal, and `1` if `y` is
+ greater than `x`.
+
+ Examples:
+
+ (compare 'a 'b) → -1
+ (compare 1 1) → 0
+ (compare \"b\" \"a\") → 1"]})
+ (op argc)
+ (op vec T (λ rest (apply vec rest))
+ {[rest+ "Return a vector constructed of the arguments.
+
+ Examples:
+
+ (vec) → #() ; empty vector
+ (vec 1 2.5 \"a\" 'b) → #(1 2.5 \"a\" b)"]})
+ (op aset! -3 (λ rest (apply aset! rest))
+ {[(sequence subscripts… new-value)+ "Modify the sequence element specified by the subscripts and return the
+ new value. The sequence can be an array, vector, a list.
+ Multi-dimensional sequences of variating types are also supported.
+
+ Examples:
+
+ (def a '((1 #(2 (3)) 4)))
+ (aset! a 1 'x) → index 1 out of bounds
+ (aset! a 0 0 'x) → x
+ a → ((x #(2 (3)) 4))
+ (aset! a 0 1 9) → 9
+ a → ((x #(9 (3)) 4))"]})
+ (op loadnil)
+ (op loadi8)
+ (op loadv.l)
+ (op loadg.l)
+ (op loada.l)
+ (op loadc.l)
+ (op setg)
+ (op setg.l)
+ (op seta.l)
+ (op vargc)
+ (op trycatch)
+ (op for 3 (λ (a b f) (for a b (λ (x) (f x))))
+ {[(min max fn)+ "Call the function `fn` with a single integer argument, starting from
+ `min` and ending with `max`.
+
+ Examples:
+
+ (for 0 2 (λ (i) (print (- 2 i)))) → 210"]})
+ (op tapply)
+ (op sub2)
+ (op argc.l)
+ (op vargc.l)
+ (op call.l)
+ (op tcall.l)
+ (op brne.l)
+ (op brnn.l)
+ (op aref -2 (λ rest (apply aref rest))
+ {[(sequence subscript0 . rest)+ "Return the sequence element specified by the subscripts. The sequence
+ can be an array, vector, a list. Multi-dimensional sequences
+ of variating types are also supported.
+
+ Examples:
+
+ (def a '((1 #(2 (3)) 4)))
+ (aref a 0) → (1 (2 (3)) 4)
+ (aref a 1) → index 1 out of bounds
+ (aref a 0 0) → 1
+ (aref a 0 1 0) → 2
+ (aref a 0 2) → 4"]})
+ (op box.l)
+ (op optargs)
+ (op dummy_eof)
+))
+
+(def (new path)
+ (file path :write :create :truncate))
+
+(let ((c-header (buffer)) ; to avoid broken code truncating valid files
+ (c-code (buffer))
+ (instructions (new "instructions.sl"))
+ (builtins (new "builtins.sl"))
+ (docs-ops (new "docs_ops.sl"))
+ (op-to-byte (table))
+ (c-op-to-op-arg (table))
+ (op-to-argc (table))
+ (op-to-closure ())
+ (i 0))
+ (io-write c-header "typedef enum {\n")+ (for-each
+ (λ (op)
+ (let {[lop (sym (op-name op))]+ [argc (op-nargs op)]}
+ (io-write c-header (str "\t" (op-cname op) ",\n"))
+ (for-each (λ (doc)
+ (let* {[args (car doc)]+ [sig (cons lop args)]
+ [docargs (cdr doc)]
+ [docstr (car docargs)]}
+ (unless (str? docstr)
+ (error lop ": documentation must be a string"))
+ (unless (or (sym? sig) (cons? sig))
+ (error lop ": invalid signature"))
+ (write `(doc-for ,sig ,@docargs) docs-ops)
+ (newline docs-ops)))
+ (op-docs op))
+ (put! op-to-byte lop (byte i))
+ (when argc
+ (put! c-op-to-op-arg (op-cname op) (list lop (if (eq? argc T) 'ANYARGS argc)))
+ (when (and (num? argc) (>= argc 0))
+ (put! op-to-argc lop argc)))
+ (set! op-to-closure (cons (op-closure op) op-to-closure))
+ (set! i (1+ i))))
+ ops)
+ (io-close docs-ops)
+ (io-write c-header "\tN_OPCODES\n}sl_op;\n\n")
+ (io-write c-header "extern const Builtin builtins[N_OPCODES];\n")
+
+ (io-write c-code "#include \"sl.h\"\n\n")
+ (io-write c-code "const Builtin builtins[N_OPCODES] = {\n")+ (for-each
+ (λ (c la) (begin (io-write c-code (str "\t[" c))
+ (io-write c-code "] = {\"")+ (write (car la) c-code)
+ (io-write c-code "\", ")
+ (write (cadr la) c-code)
+ (io-write c-code "},\n")))
+ c-op-to-op-arg)
+ (io-write c-code "};\n")
+
+ (write `(def Instructions
+ "VM instructions mapped to their encoded byte representation."
+ ,op-to-byte)
+ instructions)
+ (newline instructions)
+ (newline instructions)
+ (write `(def arg-counts
+ "VM instructions mapped to their expected arguments count."
+ ,op-to-argc)
+ instructions)
+ (newline instructions)
+ (io-close instructions)
+ (set! op-to-closure (cons vec (reverse! op-to-closure)))
+ (write `(def *builtins*
+ "VM instructions as closures."
+ ,op-to-closure)
+ builtins)
+ (newline builtins)
+ (io-close builtins)
+
+ ;; at last, copy the buffers to the actual files in git repo.
+ (io-seek c-header 0)
+ (io-copy (new "opcodes.h") c-header)
+ (io-seek c-code 0)
+ (io-copy (new "opcodes.c") c-code))
--- a/tools/mkboot0.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-(def update-compiler
- (let ((C ()))
- (with-bindings
- ((eval (λ (x) (set! C (cons (compile-thunk (macroexpand x)) C)))))
- (begin
- (load "instructions.lsp")
- (load "compiler.lsp")))
- (λ () (begin
- (for-each (λ (x) (x)) (reverse! C))
- (set! update-compiler (λ () ()))))))
-
-(def (compile-file inf)
- (let ((in (file inf :read)))
- (let next ((E (read in)))
- (if (not (io-eof? in))
- (begin
- (print (compile-thunk (macroexpand E)))
- (newline)
- (next (read in)))))
- (io-close in)))
-
-(def (do-boot0)
- (for-each (λ (file)
- (compile-file file))
- (cdr *argv*)))
-
-(update-compiler)
-(do-boot0)
--- /dev/null
+++ b/tools/mkboot0.sl
@@ -1,0 +1,28 @@
+(def update-compiler
+ (let ((C ()))
+ (with-bindings
+ ((eval (λ (x) (set! C (cons (compile-thunk (macroexpand x)) C)))))
+ (begin
+ (load "instructions.sl")
+ (load "compiler.sl")))
+ (λ () (begin
+ (for-each (λ (x) (x)) (reverse! C))
+ (set! update-compiler (λ () ()))))))
+
+(def (compile-file inf)
+ (let ((in (file inf :read)))
+ (let next ((E (read in)))
+ (if (not (io-eof? in))
+ (begin
+ (print (compile-thunk (macroexpand E)))
+ (newline)
+ (next (read in)))))
+ (io-close in)))
+
+(def (do-boot0)
+ (for-each (λ (file)
+ (compile-file file))
+ (cdr *argv*)))
+
+(update-compiler)
+(do-boot0)
--- a/tools/mkboot1.lsp
+++ /dev/null
@@ -1,7 +1,0 @@
-(load "../src/builtins.lsp")
-(load "../src/instructions.lsp")
-(load "../src/system.lsp")
-#.(load "../src/docs_extra.lsp")
-#.(load "../src/docs_ops.lsp")
-(load "../src/compiler.lsp")
-(make-system-image "sl.boot")
--- /dev/null
+++ b/tools/mkboot1.sl
@@ -1,0 +1,7 @@
+(load "../src/builtins.sl")
+(load "../src/instructions.sl")
+(load "../src/system.sl")
+#.(load "../src/docs_extra.sl")
+#.(load "../src/docs_ops.sl")
+(load "../src/compiler.sl")
+(make-system-image "sl.boot")