import femtolisp source
This commit is contained in:
JeffBezanson
parent
1f81d56b89
commit
0c9010a117
File diff suppressed because one or more lines are too long
|
|
@ -0,0 +1,41 @@
|
|||
CC = gcc
|
||||
|
||||
NAME = flisp
|
||||
SRCS = $(NAME).c builtins.c equal.c
|
||||
OBJS = $(SRCS:%.c=%.o)
|
||||
DOBJS = $(SRCS:%.c=%.do)
|
||||
EXENAME = $(NAME)
|
||||
LLT = llt/libllt.a
|
||||
|
||||
FLAGS = -Wall -Wextra -Wno-strict-aliasing -I./llt $(CFLAGS)
|
||||
LIBS = $(LLT) -lm
|
||||
|
||||
DEBUGFLAGS = -g -DDEBUG $(FLAGS)
|
||||
SHIPFLAGS = -O3 -DNDEBUG -fomit-frame-pointer $(FLAGS)
|
||||
|
||||
default: release test
|
||||
|
||||
test:
|
||||
./flisp unittest.lsp
|
||||
|
||||
%.o: %.c
|
||||
$(CC) $(SHIPFLAGS) -c $< -o $@
|
||||
%.do: %.c
|
||||
$(CC) $(DEBUGFLAGS) -c $< -o $@
|
||||
|
||||
flisp.o: flisp.c cvalues.c flisp.h print.c read.c
|
||||
flisp.do: flisp.c cvalues.c flisp.h print.c read.c
|
||||
|
||||
$(LLT):
|
||||
cd llt && make
|
||||
|
||||
debug: $(DOBJS) $(LIBS)
|
||||
$(CC) $(DEBUGFLAGS) $(DOBJS) -o $(EXENAME) $(LIBS)
|
||||
|
||||
release: $(OBJS) $(LIBS)
|
||||
$(CC) $(SHIPFLAGS) $(OBJS) -o $(EXENAME) $(LIBS)
|
||||
|
||||
clean:
|
||||
rm -f *.o
|
||||
rm -f *.do
|
||||
rm -f $(EXENAME)
|
||||
|
|
@ -0,0 +1,97 @@
|
|||
; utilities for AST processing
|
||||
|
||||
(define (symconcat s1 s2)
|
||||
(intern (string s1 s2)))
|
||||
|
||||
(define (list-adjoin item lst)
|
||||
(if (member item lst)
|
||||
lst
|
||||
(cons item lst)))
|
||||
|
||||
(define (index-of item lst start)
|
||||
(cond ((null lst) nil)
|
||||
((eq item (car lst)) start)
|
||||
(T (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (each f l)
|
||||
(if (null l) l
|
||||
(progn (f (car l))
|
||||
(each f (cdr l)))))
|
||||
|
||||
(define (maptree-pre f tr)
|
||||
(let ((new-t (f tr)))
|
||||
(if (consp new-t)
|
||||
(map (lambda (e) (maptree-pre f e)) new-t)
|
||||
new-t)))
|
||||
|
||||
(define (maptree-post f tr)
|
||||
(if (not (consp tr))
|
||||
(f tr)
|
||||
(let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
|
||||
(f new-t))))
|
||||
|
||||
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
|
||||
(define (flatten-left-op op e)
|
||||
(maptree-post (lambda (node)
|
||||
(if (and (consp node)
|
||||
(eq (car node) op)
|
||||
(consp (cdr node))
|
||||
(consp (cadr node))
|
||||
(eq (caadr node) op))
|
||||
(cons op
|
||||
(append (cdadr node) (cddr node)))
|
||||
node))
|
||||
e))
|
||||
|
||||
; convert all local variable references to (lexref rib slot name)
|
||||
; where rib is the nesting level and slot is the stack slot#
|
||||
; name is just there for reference
|
||||
; this assumes lambda is the only remaining naming form
|
||||
(define (lookup-var v env lev)
|
||||
(if (null env) v
|
||||
(let ((i (index-of v (car env) 0)))
|
||||
(if i (list 'lexref lev i v)
|
||||
(lookup-var v (cdr env) (+ lev 1))))))
|
||||
(define (lvc- e env)
|
||||
(cond ((symbolp e) (lookup-var e env 0))
|
||||
((consp e)
|
||||
(if (eq (car e) 'quote)
|
||||
e
|
||||
(let* ((newvs (and (eq (car e) 'lambda) (cadr e)))
|
||||
(newenv (if newvs (cons newvs env) env)))
|
||||
(if newvs
|
||||
(cons 'lambda
|
||||
(cons (cadr e)
|
||||
(map (lambda (se) (lvc- se newenv))
|
||||
(cddr e))))
|
||||
(map (lambda (se) (lvc- se env)) e)))))
|
||||
(T e)))
|
||||
(define (lexical-var-conversion e)
|
||||
(lvc- e ()))
|
||||
|
||||
; convert let to lambda
|
||||
(define (let-expand e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'let))
|
||||
`((lambda ,(map car (cadr n)) ,@(cddr n))
|
||||
,@(map cadr (cadr n)))
|
||||
n))
|
||||
e))
|
||||
|
||||
; 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 (assoc var m) '(0 . nil))))
|
||||
',args))
|
||||
nil)))))
|
||||
|
|
@ -0,0 +1,88 @@
|
|||
; utilities for AST processing
|
||||
|
||||
(define (symconcat s1 s2)
|
||||
(string->symbol (string-append (symbol->string s1)
|
||||
(symbol->string s2))))
|
||||
|
||||
(define (list-adjoin item lst)
|
||||
(if (memq item lst)
|
||||
lst
|
||||
(cons item lst)))
|
||||
|
||||
(define (index-of item lst start)
|
||||
(cond ((null? lst) #f)
|
||||
((eq? item (car lst)) start)
|
||||
(else (index-of item (cdr lst) (+ start 1)))))
|
||||
|
||||
(define (map! f l)
|
||||
(define (map!- f l start)
|
||||
(if (pair? l)
|
||||
(begin (set-car! l (f (car l)))
|
||||
(map!- f (cdr l) start))
|
||||
start))
|
||||
(map!- f l l))
|
||||
|
||||
(define (each f l)
|
||||
(if (null? l) l
|
||||
(begin (f (car l))
|
||||
(each f (cdr l)))))
|
||||
|
||||
(define (maptree-pre f t)
|
||||
(let ((new-t (f t)))
|
||||
(if (pair? new-t)
|
||||
(map (lambda (e) (maptree-pre f e)) new-t)
|
||||
new-t)))
|
||||
|
||||
(define (maptree-post f t)
|
||||
(if (not (pair? t))
|
||||
(f t)
|
||||
(let ((new-t (map (lambda (e) (maptree-post f e)) t)))
|
||||
(f new-t))))
|
||||
|
||||
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
|
||||
(define (flatten-left-op op e)
|
||||
(maptree-post (lambda (node)
|
||||
(if (and (pair? node)
|
||||
(eq? (car node) op)
|
||||
(pair? (cdr node))
|
||||
(pair? (cadr node))
|
||||
(eq? (caadr node) op))
|
||||
(cons op
|
||||
(append (cdadr node) (cddr node)))
|
||||
node))
|
||||
e))
|
||||
|
||||
; convert all local variable references to (lexref rib slot name)
|
||||
; where rib is the nesting level and slot is the stack slot#
|
||||
; name is just there for reference
|
||||
; this assumes lambda is the only remaining naming form
|
||||
(define (lexical-var-conversion e)
|
||||
(define (lookup-var v env lev)
|
||||
(if (null? env) v
|
||||
(let ((i (index-of v (car env) 0)))
|
||||
(if i (list 'lexref lev i v)
|
||||
(lookup-var v (cdr env) (+ lev 1))))))
|
||||
(define (lvc- e env)
|
||||
(cond ((symbol? e) (lookup-var e env 0))
|
||||
((pair? e)
|
||||
(if (eq? (car e) 'quote)
|
||||
e
|
||||
(let* ((newvs (and (eq? (car e) 'lambda) (cadr e)))
|
||||
(newenv (if newvs (cons newvs env) env)))
|
||||
(if newvs
|
||||
(cons 'lambda
|
||||
(cons (cadr e)
|
||||
(map (lambda (se) (lvc- se newenv))
|
||||
(cddr e))))
|
||||
(map (lambda (se) (lvc- se env)) e)))))
|
||||
(else e)))
|
||||
(lvc- e ()))
|
||||
|
||||
; convert let to lambda
|
||||
(define (let-expand e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (pair? n) (eq? (car n) 'let))
|
||||
`((lambda ,(map car (cadr n)) ,@(cddr n))
|
||||
,@(map cadr (cadr n)))
|
||||
n))
|
||||
e))
|
||||
|
|
@ -0,0 +1,181 @@
|
|||
; tree regular expression pattern matching
|
||||
; by Jeff Bezanson
|
||||
|
||||
(define (unique lst)
|
||||
(if (null lst)
|
||||
()
|
||||
(cons (car lst)
|
||||
(filter (lambda (x) (not (eq x (car lst))))
|
||||
(unique (cdr lst))))))
|
||||
|
||||
; list of special pattern symbols that cannot be variable names
|
||||
(define metasymbols '(_ ...))
|
||||
|
||||
; expression tree pattern matching
|
||||
; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
|
||||
; mapping variables to captured subexpressions, or #f if no match.
|
||||
; when a match succeeds, __ is always bound to the whole matched expression.
|
||||
;
|
||||
; p is an expression in the following pattern language:
|
||||
;
|
||||
; _ match anything, not captured
|
||||
; <func> any scheme function; matches if (func expr) returns #t
|
||||
; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
|
||||
; must match the same thing.
|
||||
; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
|
||||
; subpatterns matched recursively.
|
||||
; (-/ <ex>) match <ex> literally
|
||||
; (-^ <p>) complement of pattern <p>
|
||||
; (-- <var> <p>) match <p> and capture as <var> if match succeeds
|
||||
;
|
||||
; regular match constructs:
|
||||
; ... match any number of anything
|
||||
; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
|
||||
; (-* <p>) match any number of <p>
|
||||
; (-? <p>) match 0 or 1 of <p>
|
||||
; (-+ <p>) match at least 1 of <p>
|
||||
; all of these can be wrapped in (-- var ) for capturing purposes
|
||||
; This is NP-complete. Be careful.
|
||||
;
|
||||
(define (match- p expr state)
|
||||
(cond ((symbolp p)
|
||||
(cond ((eq p '_) state)
|
||||
(T
|
||||
(let ((capt (assoc p state)))
|
||||
(if capt
|
||||
(and (equal expr (cdr capt)) state)
|
||||
(cons (cons p expr) state))))))
|
||||
|
||||
((functionp p)
|
||||
(and (p expr) state))
|
||||
|
||||
((consp p)
|
||||
(cond ((eq (car p) '-/) (and (equal (cadr p) expr) state))
|
||||
((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
|
||||
((eq (car p) '--)
|
||||
(and (match- (caddr p) expr state)
|
||||
(cons (cons (cadr p) expr) state)))
|
||||
((eq (car p) '-$) ; greedy alternation for toplevel pattern
|
||||
(match-alt (cdr p) () (list expr) state nil 1))
|
||||
(T
|
||||
(and (consp expr)
|
||||
(equal (car p) (car expr))
|
||||
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
|
||||
|
||||
(T
|
||||
(and (equal p expr) state))))
|
||||
|
||||
; match an alternation
|
||||
(define (match-alt alt prest expr state var L)
|
||||
(if (null alt) nil ; no alternatives left
|
||||
(let ((subma (match- (car alt) (car expr) state)))
|
||||
(or (and subma
|
||||
(match-seq prest (cdr expr)
|
||||
(if var
|
||||
(cons (cons var (car expr))
|
||||
subma)
|
||||
subma)
|
||||
(- L 1)))
|
||||
(match-alt (cdr alt) prest expr state var L)))))
|
||||
|
||||
; match generalized kleene star (try consuming min to max)
|
||||
(define (match-star- p prest expr state var min max L sofar)
|
||||
(cond ; case 0: impossible to match
|
||||
((> min max) 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
|
||||
(T
|
||||
(or (match-star- p prest expr state var 0 0 L sofar)
|
||||
(match-star- p prest expr state var 1 max L sofar)))))
|
||||
(define (match-star p prest expr state var min max L)
|
||||
(match-star- p prest expr state var min max L ()))
|
||||
|
||||
; match sequences of expressions
|
||||
(define (match-seq p expr state L)
|
||||
(cond ((not state) nil)
|
||||
((null p) (if (null expr) state nil))
|
||||
(T
|
||||
(let ((subp (car p))
|
||||
(var nil))
|
||||
(if (and (consp subp)
|
||||
(eq (car subp) '--))
|
||||
(progn (setq var (cadr subp))
|
||||
(setq subp (caddr subp)))
|
||||
nil)
|
||||
(let ((head (if (consp subp) (car subp) ())))
|
||||
(cond ((eq subp '...)
|
||||
(match-star '_ (cdr p) expr state var 0 L L))
|
||||
((eq head '-*)
|
||||
(match-star (cadr subp) (cdr p) expr state var 0 L L))
|
||||
((eq head '-+)
|
||||
(match-star (cadr subp) (cdr p) expr state var 1 L L))
|
||||
((eq head '-?)
|
||||
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
|
||||
((eq head '-$)
|
||||
(match-alt (cdr subp) (cdr p) expr state var L))
|
||||
(T
|
||||
(and (consp expr)
|
||||
(match-seq (cdr p) (cdr expr)
|
||||
(match- (car p) (car expr) state)
|
||||
(- L 1))))))))))
|
||||
|
||||
(define (match p expr) (match- p expr (list (cons '__ expr))))
|
||||
|
||||
; given a pattern p, return the list of capturing variables it uses
|
||||
(define (patargs- p)
|
||||
(cond ((and (symbolp p)
|
||||
(not (member p metasymbols)))
|
||||
(list p))
|
||||
|
||||
((consp p)
|
||||
(if (eq (car p) '-/)
|
||||
()
|
||||
(unique (apply append (map patargs- (cdr p))))))
|
||||
|
||||
(T ())))
|
||||
(define (patargs p)
|
||||
(cons '__ (patargs- p)))
|
||||
|
||||
; try to transform expr using a pattern-lambda from plist
|
||||
; returns the new expression, or expr if no matches
|
||||
(define (apply-patterns plist expr)
|
||||
(if (null plist) expr
|
||||
(if (functionp plist)
|
||||
(let ((enew (plist expr)))
|
||||
(if (not enew)
|
||||
expr
|
||||
enew))
|
||||
(let ((enew ((car plist) expr)))
|
||||
(if (not enew)
|
||||
(apply-patterns (cdr plist) expr)
|
||||
enew)))))
|
||||
|
||||
; top-down fixed-point macroexpansion. this is a typical algorithm,
|
||||
; but it may leave some structure that matches a pattern unexpanded.
|
||||
; the advantage is that non-terminating cases cannot arise as a result
|
||||
; of expression composition. in other words, if the outer loop terminates
|
||||
; on all inputs for a given set of patterns, then the whole algorithm
|
||||
; terminates. pattern sets that violate this should be easier to detect,
|
||||
; for example
|
||||
; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
|
||||
; TODO: ignore quoted expressions
|
||||
(define (pattern-expand plist expr)
|
||||
(if (not (consp 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)))))
|
||||
|
|
@ -0,0 +1,181 @@
|
|||
; tree regular expression pattern matching
|
||||
; by Jeff Bezanson
|
||||
|
||||
(define (unique lst)
|
||||
(if (null? lst)
|
||||
()
|
||||
(cons (car lst)
|
||||
(filter (lambda (x) (not (eq? x (car lst))))
|
||||
(unique (cdr lst))))))
|
||||
|
||||
; list of special pattern symbols that cannot be variable names
|
||||
(define metasymbols '(_ ...))
|
||||
|
||||
; expression tree pattern matching
|
||||
; matches expr against pattern p and returns an assoc list ((var . expr) (var . expr) ...)
|
||||
; mapping variables to captured subexpressions, or #f if no match.
|
||||
; when a match succeeds, __ is always bound to the whole matched expression.
|
||||
;
|
||||
; p is an expression in the following pattern language:
|
||||
;
|
||||
; _ match anything, not captured
|
||||
; <func> any scheme function; matches if (func expr) returns #t
|
||||
; <var> match anything and capture as <var>. future occurrences of <var> in the pattern
|
||||
; must match the same thing.
|
||||
; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the
|
||||
; subpatterns matched recursively.
|
||||
; (-/ <ex>) match <ex> literally
|
||||
; (-^ <p>) complement of pattern <p>
|
||||
; (-- <var> <p>) match <p> and capture as <var> if match succeeds
|
||||
;
|
||||
; regular match constructs:
|
||||
; ... match any number of anything
|
||||
; (-$ <p1> <p2> etc) match any of subpatterns <p1>, <p2>, etc
|
||||
; (-* <p>) match any number of <p>
|
||||
; (-? <p>) match 0 or 1 of <p>
|
||||
; (-+ <p>) match at least 1 of <p>
|
||||
; all of these can be wrapped in (-- var ) for capturing purposes
|
||||
; This is NP-complete. Be careful.
|
||||
;
|
||||
(define (match- p expr state)
|
||||
(cond ((symbol? p)
|
||||
(cond ((eq? p '_) state)
|
||||
(else
|
||||
(let ((capt (assq p state)))
|
||||
(if capt
|
||||
(and (equal? expr (cdr capt)) state)
|
||||
(cons (cons p expr) state))))))
|
||||
|
||||
((procedure? p)
|
||||
(and (p expr) state))
|
||||
|
||||
((pair? p)
|
||||
(cond ((eq? (car p) '-/) (and (equal? (cadr p) expr) state))
|
||||
((eq? (car p) '-^) (and (not (match- (cadr p) expr state)) state))
|
||||
((eq? (car p) '--)
|
||||
(and (match- (caddr p) expr state)
|
||||
(cons (cons (cadr p) expr) state)))
|
||||
((eq? (car p) '-$) ; greedy alternation for toplevel pattern
|
||||
(match-alt (cdr p) () (list expr) state #f 1))
|
||||
(else
|
||||
(and (pair? expr)
|
||||
(equal? (car p) (car expr))
|
||||
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
|
||||
|
||||
(else
|
||||
(and (equal? p expr) state))))
|
||||
|
||||
; match an alternation
|
||||
(define (match-alt alt prest expr state var L)
|
||||
(if (null? alt) #f ; no alternatives left
|
||||
(let ((subma (match- (car alt) (car expr) state)))
|
||||
(or (and subma
|
||||
(match-seq prest (cdr expr)
|
||||
(if var
|
||||
(cons (cons var (car expr))
|
||||
subma)
|
||||
subma)
|
||||
(- L 1)))
|
||||
(match-alt (cdr alt) prest expr state var L)))))
|
||||
|
||||
; match generalized kleene star (try consuming min to max)
|
||||
(define (match-star p prest expr state var min max L)
|
||||
(define (match-star- p prest expr state var min max L sofar)
|
||||
(cond ; case 0: impossible to match
|
||||
((> min max) #f)
|
||||
; case 1: only allowed to match 0 subexpressions
|
||||
((= max 0) (match-seq prest expr
|
||||
(if var (cons (cons var (reverse sofar)) state)
|
||||
state)
|
||||
L))
|
||||
; case 2: must match at least 1
|
||||
((> min 0)
|
||||
(and (match- p (car expr) state)
|
||||
(match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1)
|
||||
(cons (car expr) sofar))))
|
||||
; otherwise, must match either 0 or between 1 and max subexpressions
|
||||
(else
|
||||
(or (match-star- p prest expr state var 0 0 L sofar)
|
||||
(match-star- p prest expr state var 1 max L sofar)))))
|
||||
|
||||
(match-star- p prest expr state var min max L ()))
|
||||
|
||||
; match sequences of expressions
|
||||
(define (match-seq p expr state L)
|
||||
(cond ((not state) #f)
|
||||
((null? p) (if (null? expr) state #f))
|
||||
(else
|
||||
(let ((subp (car p))
|
||||
(var #f))
|
||||
(if (and (pair? subp)
|
||||
(eq? (car subp) '--))
|
||||
(begin (set! var (cadr subp))
|
||||
(set! subp (caddr subp)))
|
||||
#f)
|
||||
(let ((head (if (pair? subp) (car subp) ())))
|
||||
(cond ((eq? subp '...)
|
||||
(match-star '_ (cdr p) expr state var 0 L L))
|
||||
((eq? head '-*)
|
||||
(match-star (cadr subp) (cdr p) expr state var 0 L L))
|
||||
((eq? head '-+)
|
||||
(match-star (cadr subp) (cdr p) expr state var 1 L L))
|
||||
((eq? head '-?)
|
||||
(match-star (cadr subp) (cdr p) expr state var 0 1 L))
|
||||
((eq? head '-$)
|
||||
(match-alt (cdr subp) (cdr p) expr state var L))
|
||||
(else
|
||||
(and (pair? expr)
|
||||
(match-seq (cdr p) (cdr expr)
|
||||
(match- (car p) (car expr) state)
|
||||
(- L 1))))))))))
|
||||
|
||||
(define (match p expr) (match- p expr (list (cons '__ expr))))
|
||||
|
||||
; given a pattern p, return the list of capturing variables it uses
|
||||
(define (patargs p)
|
||||
(define (patargs- p)
|
||||
(cond ((and (symbol? p)
|
||||
(not (member p metasymbols)))
|
||||
(list p))
|
||||
|
||||
((pair? p)
|
||||
(if (eq? (car p) '-/)
|
||||
()
|
||||
(unique (apply append (map patargs- (cdr p))))))
|
||||
|
||||
(else ())))
|
||||
(cons '__ (patargs- p)))
|
||||
|
||||
; try to transform expr using a pattern-lambda from plist
|
||||
; returns the new expression, or expr if no matches
|
||||
(define (apply-patterns plist expr)
|
||||
(if (null? plist) expr
|
||||
(if (procedure? plist)
|
||||
(let ((enew (plist expr)))
|
||||
(if (not enew)
|
||||
expr
|
||||
enew))
|
||||
(let ((enew ((car plist) expr)))
|
||||
(if (not enew)
|
||||
(apply-patterns (cdr plist) expr)
|
||||
enew)))))
|
||||
|
||||
; top-down fixed-point macroexpansion. this is a typical algorithm,
|
||||
; but it may leave some structure that matches a pattern unexpanded.
|
||||
; the advantage is that non-terminating cases cannot arise as a result
|
||||
; of expression composition. in other words, if the outer loop terminates
|
||||
; on all inputs for a given set of patterns, then the whole algorithm
|
||||
; terminates. pattern sets that violate this should be easier to detect,
|
||||
; for example
|
||||
; (pattern-lambda (/ 2 3) '(/ 3 2)), (pattern-lambda (/ 3 2) '(/ 2 3))
|
||||
; TODO: ignore quoted expressions
|
||||
(define (pattern-expand plist expr)
|
||||
(if (not (pair? expr))
|
||||
expr
|
||||
(let ((enew (apply-patterns plist expr)))
|
||||
(if (eq? enew expr)
|
||||
; expr didn't change; move to subexpressions
|
||||
(cons (car expr)
|
||||
(map (lambda (subex) (pattern-expand plist subex)) (cdr expr)))
|
||||
; expr changed; iterate
|
||||
(pattern-expand plist enew)))))
|
||||
File diff suppressed because one or more lines are too long
|
|
@ -0,0 +1,23 @@
|
|||
; pattern-lambda syntax for jscheme
|
||||
|
||||
; pattern-lambda abstraction
|
||||
; this is a generalization of lambda:
|
||||
;
|
||||
; ((pattern-lambda p body) expr)
|
||||
; Matches expr against p. If no match, return #null. If match succeeds, evaluate body
|
||||
; with variables in p bound to whatever they matched in expr.
|
||||
;
|
||||
; EXAMPLE: Recognize adding any expression x to itself, replace with 2*x.
|
||||
; (define selfadd (pattern-lambda (+ x x) `(* 2 ,x)))
|
||||
; Then (selfadd '(+ (foo bar) (foo bar))) returns (* 2 (foo bar))
|
||||
;
|
||||
(define-macro (pattern-lambda pat body)
|
||||
(let* ((args (patargs pat))
|
||||
(expander `(lambda ,args ,body)))
|
||||
`(lambda (expr)
|
||||
(let ((m (match ',pat expr)))
|
||||
(if m
|
||||
; matches; perform expansion
|
||||
(apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . #f))))
|
||||
',args))
|
||||
#f)))))
|
||||
Binary file not shown.
|
|
@ -0,0 +1,121 @@
|
|||
(load '|match.lsp|)
|
||||
(load '|asttools.lsp|)
|
||||
|
||||
(define missing-arg-tag '*r-missing*)
|
||||
|
||||
; tree inspection utils
|
||||
|
||||
(define (assigned-var e)
|
||||
(and (consp e)
|
||||
(or (eq (car e) '<-) (eq (car e) 'ref=))
|
||||
(symbolp (cadr e))
|
||||
(cadr e)))
|
||||
|
||||
(define (func-argnames f)
|
||||
(let ((argl (cadr f)))
|
||||
(if (eq argl '*r-null*) ()
|
||||
(map cadr argl))))
|
||||
|
||||
; transformations
|
||||
|
||||
(define (dollarsign-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda ($ lhs name)
|
||||
(let* ((g (if (not (consp lhs)) lhs (gensym)))
|
||||
(n (if (symbolp name)
|
||||
name ;(symbol->string name)
|
||||
name))
|
||||
(expr `(r-call
|
||||
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
|
||||
(if (not (consp lhs))
|
||||
expr
|
||||
`(r-block (ref= ,g ,lhs) ,expr))))
|
||||
e))
|
||||
|
||||
; lower r expressions of the form f(lhs,...) <- rhs
|
||||
; TODO: if there are any special forms that can be f in this expression,
|
||||
; they need to be handled separately. For example a$b can be lowered
|
||||
; to an index assignment (by dollarsign-transform), after which
|
||||
; this transform applies. I don't think there are any others though.
|
||||
(define (fancy-assignment-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
|
||||
(<<- (r-call f lhs ...) rhs))
|
||||
(let ((g (if (consp rhs) (gensym) rhs))
|
||||
(op (car __)))
|
||||
`(r-block ,@(if (consp rhs) `((ref= ,g ,rhs)) ())
|
||||
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
|
||||
,g)))
|
||||
e))
|
||||
|
||||
; map an arglist with default values to appropriate init code
|
||||
; function(x=blah) { ... } gets
|
||||
; if (missing(x)) x = blah
|
||||
; added to its body
|
||||
(define (gen-default-inits arglist)
|
||||
(map (lambda (arg)
|
||||
(let ((name (cadr arg))
|
||||
(default (caddr arg)))
|
||||
`(when (missing ,name)
|
||||
(<- ,name ,default))))
|
||||
(filter (lambda (arg) (not (eq (caddr arg) missing-arg-tag))) arglist)))
|
||||
|
||||
; convert r function expressions to lambda
|
||||
(define (normalize-r-functions e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'function))
|
||||
`(lambda ,(func-argnames n)
|
||||
(r-block ,@(gen-default-inits (cadr n))
|
||||
,@(if (and (consp (caddr n))
|
||||
(eq (car (caddr n)) 'r-block))
|
||||
(cdr (caddr n))
|
||||
(list (caddr n)))))
|
||||
n))
|
||||
e))
|
||||
|
||||
(define (find-assigned-vars n)
|
||||
(let ((vars ()))
|
||||
(maptree-pre (lambda (s)
|
||||
(if (not (consp s)) s
|
||||
(cond ((eq (car s) 'lambda) nil)
|
||||
((eq (car s) '<-)
|
||||
(setq vars (list-adjoin (cadr s) vars))
|
||||
(cddr s))
|
||||
(T s))))
|
||||
n)
|
||||
vars))
|
||||
|
||||
; introduce let based on assignment statements
|
||||
(define (letbind-locals e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (consp n) (eq (car n) 'lambda))
|
||||
(let ((vars (find-assigned-vars (cddr n))))
|
||||
`(lambda ,(cadr n) (let ,(map (lambda (v) (list v ()))
|
||||
vars)
|
||||
,@(cddr n))))
|
||||
n))
|
||||
e))
|
||||
|
||||
(define (compile-ish e)
|
||||
(letbind-locals
|
||||
(normalize-r-functions
|
||||
(fancy-assignment-transform
|
||||
(dollarsign-transform
|
||||
(flatten-all-op && (flatten-all-op \|\| e)))))))
|
||||
|
||||
;(trace map)
|
||||
;(pretty-print (compile-ish *input*))
|
||||
;(print
|
||||
; (time-call (lambda () (compile-ish *input*)) 1)
|
||||
;)
|
||||
(define (main)
|
||||
(progn
|
||||
(define *input* (read))
|
||||
;(define t0 ((java.util.Date:new):getTime))
|
||||
(clock)
|
||||
(compile-ish *input*)
|
||||
(clock)
|
||||
;(define t1 ((java.util.Date:new):getTime))
|
||||
))
|
||||
|
||||
(main)
|
||||
|
|
@ -0,0 +1,206 @@
|
|||
(include "iscutil.scm")
|
||||
(include "match.scm")
|
||||
(include "asttools.scm")
|
||||
;(load "plambda-js.scm")
|
||||
;(load "plambda-chez.scm")
|
||||
|
||||
;(pretty-print *input*)
|
||||
|
||||
#|
|
||||
Overall phases:
|
||||
I. s-expr output
|
||||
II. tree normalization
|
||||
1. control construct normalization, flattening. various restructuring.
|
||||
2. transformations that might add variables
|
||||
3. local variable detection
|
||||
III. var/func attribute analysis
|
||||
IV. argument normalization
|
||||
V. type inference
|
||||
1. split each function into generic/non-generic versions. the generic
|
||||
one resolves generic funcs to calls to a lookup routine that tries
|
||||
to find stuff like `diag<-.darray`. the other one assumes everything
|
||||
is handled by a builtin R function with a known t-function
|
||||
2. inference
|
||||
VI. code generation
|
||||
|
||||
Useful R lowering passes:
|
||||
|
||||
- control construct normalization
|
||||
. convert while/repeat/various for forms/break/next to while/break
|
||||
. convert switch to nested if
|
||||
|
||||
- local variable detection
|
||||
. classify vars as (1) definitely local, (2) possibly-local, (3) free
|
||||
. collect all local or possibly-local vars and wrap the body with
|
||||
(let ((g0 (upvalue 'var1))
|
||||
(g1 (upvalue 'var2)))
|
||||
<body>)
|
||||
|
||||
where (upvalue x) is either (get-global x) or (captured-var n i)
|
||||
for definitely-local, start as null instead of upvalue
|
||||
|
||||
then we have to rename var1 to g0 everywhere inside that.
|
||||
for the vast majority of functions that don't attempt to modify parent-scope
|
||||
locals, pure-functional closure conversion would work.
|
||||
|
||||
utility for this: fold-along-cfg
|
||||
. after this the tree is ready for typical lexical scope analysis
|
||||
|
||||
(- closure conversion/deBruijn indices)
|
||||
|
||||
- argument normalization for call to known function
|
||||
. convert lambda arglist to plain list of symbols
|
||||
. move default initializers into body as `(when (eq? ,argname 'missing) ,assign)
|
||||
. at call site sort args to correct positions, add explicit missing
|
||||
. if call target unknown insert call to match.args or whatever
|
||||
|
||||
- r-block, ||, && flattening
|
||||
|
||||
- fancy assignment transformation:
|
||||
f(v) <- rhs, (<- (r-call f v) rhs)
|
||||
performs:
|
||||
(begin (<- v (r-call f<- v rhs))
|
||||
rhs)
|
||||
|
||||
- (<- a b) becomes (ref= a (lazy-copy b))
|
||||
arguments to functions are wrapped in lazy-copy at the call site, so we can
|
||||
omit the copy (1) for functions marked as pass-by-ref, (2) where user indicated
|
||||
pass-by-ref, (3) for arguments which are strictly-allocating expressions,
|
||||
(4) for user functions proven to be ref-safe and thus marked as case (1)
|
||||
|
||||
Useful analyses:
|
||||
|
||||
- prove function strictness!!
|
||||
. strict functions need to open with (if (promise? arg) (force arg) arg) for each
|
||||
arg, in case they are called indirectly.
|
||||
- prove global variables constant (esp. function names)
|
||||
. prove builtins redefined/constant
|
||||
- need dictionary of builtin properties (pure/strict/t-functions/etc.)
|
||||
- useful but very general types:
|
||||
single: has length 1 and no attrs (implies simple)
|
||||
simple: has default class attributes
|
||||
array: has dim attribute only
|
||||
distributed: starp array
|
||||
numeric
|
||||
|#
|
||||
|
||||
|
||||
(define missing-arg-tag '*r-missing*)
|
||||
|
||||
; tree inspection utils
|
||||
|
||||
(define (assigned-var e)
|
||||
(and (pair? e)
|
||||
(or (eq? (car e) '<-) (eq? (car e) 'ref=))
|
||||
(symbol? (cadr e))
|
||||
(cadr e)))
|
||||
|
||||
(define (func-argnames f)
|
||||
(let ((argl (cadr f)))
|
||||
(if (eq? argl '*r-null*) ()
|
||||
(map cadr argl))))
|
||||
|
||||
; transformations
|
||||
|
||||
(define (dollarsign-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda ($ lhs name)
|
||||
(let* ((g (if (not (pair? lhs)) lhs (gensym)))
|
||||
(n (if (symbol? name)
|
||||
(symbol->string name)
|
||||
name))
|
||||
(expr `(r-call
|
||||
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
|
||||
(if (not (pair? lhs))
|
||||
expr
|
||||
`(r-block (ref= ,g ,lhs) ,expr))))
|
||||
e))
|
||||
|
||||
; lower r expressions of the form f(lhs,...) <- rhs
|
||||
; TODO: if there are any special forms that can be f in this expression,
|
||||
; they need to be handled separately. For example a$b can be lowered
|
||||
; to an index assignment (by dollarsign-transform), after which
|
||||
; this transform applies. I don't think there are any others though.
|
||||
(define (fancy-assignment-transform e)
|
||||
(pattern-expand
|
||||
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
|
||||
(<<- (r-call f lhs ...) rhs))
|
||||
(let ((g (if (pair? rhs) (gensym) rhs))
|
||||
(op (car __)))
|
||||
`(r-block ,@(if (pair? rhs) `((ref= ,g ,rhs)) ())
|
||||
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
|
||||
,g)))
|
||||
e))
|
||||
|
||||
; map an arglist with default values to appropriate init code
|
||||
; function(x=blah) { ... } gets
|
||||
; if (missing(x)) x = blah
|
||||
; added to its body
|
||||
(define (gen-default-inits arglist)
|
||||
(map (lambda (arg)
|
||||
(let ((name (cadr arg))
|
||||
(default (caddr arg)))
|
||||
`(when (missing ,name)
|
||||
(<- ,name ,default))))
|
||||
(filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist)))
|
||||
|
||||
; convert r function expressions to lambda
|
||||
(define (normalize-r-functions e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (pair? n) (eq? (car n) 'function))
|
||||
`(lambda ,(func-argnames n)
|
||||
(r-block ,@(gen-default-inits (cadr n))
|
||||
,@(if (and (pair? (caddr n))
|
||||
(eq? (car (caddr n)) 'r-block))
|
||||
(cdr (caddr n))
|
||||
(list (caddr n)))))
|
||||
n))
|
||||
e))
|
||||
|
||||
(define (find-assigned-vars n)
|
||||
(let ((vars ()))
|
||||
(maptree-pre (lambda (s)
|
||||
(if (not (pair? s)) s
|
||||
(cond ((eq? (car s) 'lambda) #f)
|
||||
((eq? (car s) '<-)
|
||||
(set! vars (list-adjoin (cadr s) vars))
|
||||
(cddr s))
|
||||
(else s))))
|
||||
n)
|
||||
vars))
|
||||
|
||||
; introduce let based on assignment statements
|
||||
(define (letbind-locals e)
|
||||
(maptree-post (lambda (n)
|
||||
(if (and (pair? n) (eq? (car n) 'lambda))
|
||||
(let ((vars (find-assigned-vars (cddr n))))
|
||||
`(lambda ,(cadr n) (let ,(map list
|
||||
vars
|
||||
(map (lambda (x) '()) vars))
|
||||
,@(cddr n))))
|
||||
n))
|
||||
e))
|
||||
|
||||
(define (compile-ish e)
|
||||
(letbind-locals
|
||||
(normalize-r-functions
|
||||
(fancy-assignment-transform
|
||||
(dollarsign-transform
|
||||
(flatten-all-op && (flatten-all-op || e)))))))
|
||||
|
||||
;(trace map)
|
||||
;(pretty-print (compile-ish *input*))
|
||||
;(print
|
||||
; (time-call (lambda () (compile-ish *input*)) 1)
|
||||
;)
|
||||
(define (main)
|
||||
(begin
|
||||
(define *input* (read))
|
||||
(define t0 ((java.util.Date:new):getTime))
|
||||
(compile-ish *input*)
|
||||
(define t1 ((java.util.Date:new):getTime))
|
||||
(display "milliseconds: ")
|
||||
(display (- t1 t0))
|
||||
(newline)))
|
||||
|
||||
(main)
|
||||
|
|
@ -0,0 +1,120 @@
|
|||
(r-expressions
|
||||
(r-call library \M\A\S\S)
|
||||
(r-call dyn.load "starp.so")
|
||||
(<- ppcommand (function ((*named* ... *r-missing*)) (r-call .\Call "ppcommand" (r-call list r-dotdotdot)) ()))
|
||||
(<- ppvcommand (function ((*named* va *r-missing*)) (r-call .\Call "ppcommand" va) ()))
|
||||
(<- ppinvoke ppcommand)
|
||||
(<- pploadconfig (function ((*named* fileName *r-missing*)) (r-call .\Call "pploadconfig" file\Name) ()))
|
||||
(<- ppconnect (function ((*named* numProcs ()) (*named* machines ())) (r-call .\Call "ppconnect" (r-call list num\Procs machines)) ()))
|
||||
(<- ppgetlogpath (function () (r-call .\Call "ppgetlogpath") ()))
|
||||
(<- ppgetlog (function () (r-call .\Call "ppgetlog") ()))
|
||||
(<- ppshowdashboard (function () (r-call .\Call "ppshowdashboard") ()))
|
||||
(<- pphidedashboard (function () (r-call .\Call "pphidedashboard") ()))
|
||||
(<- revealargs (function ((*named* dots *r-missing*)) (r-call .\Call "_revealArgs" dots) ()))
|
||||
(<- listargs (function ((*named* ... *r-missing*)) (r-call revealargs (r-call get "...")) ()))
|
||||
(<- ppping (function () (r-call ppcommand "ppping") ()))
|
||||
(<- ppver (function () (r-call ppcommand "pp_ver") ()))
|
||||
(<- \S\T\A\R\P\D\I\S\T "../../../linkdist")
|
||||
(<- \S\T\A\R\P\P\L\A\T\F\O\R\M "ia32_linux")
|
||||
(r-call .\Call "_setstarpdist" \S\T\A\R\P\D\I\S\T)
|
||||
(r-call .\Call "_setstarpplat" \S\T\A\R\P\P\L\A\T\F\O\R\M)
|
||||
(r-call pploadconfig (r-call paste \S\T\A\R\P\D\I\S\T "/config/starpd.properties" (*named* sep "")))
|
||||
(<- dimdis (function ((*named* v *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class v) 1) "dlayoutn") (return (r-call as.numeric (r-call r-index (r-call class v) 2)))) (if (r-call ! (r-call is.null v)) (r-block (for i (r-call : (r-call length v) 1) (if (r-call > (r-call r-aref v i) 1) (return i)))) (r-block (return 1))) (return (r-call length v))) ()))
|
||||
(<- is.scalar (function ((*named* x *r-missing*)) (&& (&& (\|\| (r-call == (r-call mode x) "numeric") (r-call == (r-call mode x) "complex")) (r-call is.null (r-call (r-call .\Primitive "dim") x))) (r-call == (r-call length x) 1)) ()))
|
||||
(<- p 1)
|
||||
(<- (r-call class p) (r-call c "dlayout" "numeric"))
|
||||
(<- darray (function ((*named* id *r-missing*) (*named* shape *r-missing*) (*named* distribution *r-missing*) (*named* isreal *r-missing*)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (<- (r-call class shape) (r-call append "dlayoutn" (r-call to\String distribution) (r-call class shape))) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) () ())) (<- (r-call class d) "darray") d) ()))
|
||||
(<- darraydist (function ((*named* da *r-missing*)) (r-call as.numeric (r-call r-aref (r-call class ($ da shape)) 2)) ()))
|
||||
(<- is.darray (function ((*named* x *r-missing*)) (r-call == (r-call r-index (r-call class x) 1) "darray") ()))
|
||||
(<- is.nd (function ((*named* x *r-missing*)) (r-call != (r-call length (r-call dim x)) 2) ()))
|
||||
(<- is.darraynd (function ((*named* x *r-missing*)) (&& (r-call is.darray x) (r-call is.nd x)) ()))
|
||||
(<- is.dlayout (function ((*named* x *r-missing*)) (r-call any (r-call == (r-call class x) "dlayout")) ()))
|
||||
(<- vdim (function ((*named* x *r-missing*)) (if (r-call is.vector x) (r-call length x) (r-call dim x)) ()))
|
||||
(<- \[\[.dlayoutn (<- \[.dlayoutn (function ((*named* dl *r-missing*) (*named* n *r-missing*)) (r-block (<- dd (r-call as.numeric (r-call r-aref (r-call class dl) 2))) (if (r-call == (r-call length n) 1) (r-block (if (r-call == n dd) (r-call * (r-call r-index (r-call as.vector dl) n) p) (r-call r-index (r-call as.vector dl) n))) (r-block (<- r (r-call r-index (r-call as.numeric dl) n)) (<- didi (r-call dimdis r)) (for i (r-call : 1 (r-call length n)) (r-block (if (r-call == (r-call r-aref n i) dd) (r-block (<- didi i) (break))))) (<- (r-call class r) (r-call append "dlayoutn" (r-call to\String didi) (r-call class r))) (return r)))) ())))
|
||||
(<- print.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- sh (r-call as.vector ($ d shape))) (<- shs (r-call deparse sh)) (if (r-call > (r-call length sh) 1) (r-block (<- shs (r-call substring shs 2))) (r-block (<- shs (r-call paste "(" shs ")" (*named* sep ""))))) (r-call print.default (r-call paste "<darray id:" ($ d id) " shape:" shs " distribution:" (r-call r-aref (r-call class ($ d shape)) 2) ">" (*named* sep "")) (*named* quote *r-false*)) (r-call invisible d)) ()))
|
||||
(<- validdist (function ((*named* dims *r-missing*) (*named* dd *r-missing*)) (r-block (if (\|\| (r-call > dd (r-call length dims)) (r-call == (r-call r-aref dims dd) 1)) (return (r-call dimdis (r-call as.vector dims)))) (return dd)) ()))
|
||||
(<- dim.darray (function ((*named* x *r-missing*)) ($ x shape) ()))
|
||||
(<- dim<-.darray (function ((*named* x *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call == (r-call r-index (r-call class value) 1) "dlayoutn") (r-block (<- dd (r-call as.numeric (r-call r-index (r-call class value) 2)))) (<- dd (r-call darraydist x))) (<- dd (r-call validdist value dd)) (if (&& (r-call == (r-call length value) 2) (r-call == (r-call length ($ x shape)) 2)) (r-block (r-call ppcommand "ppdense_reshape" x (r-call r-aref value 1) (r-call - dd 1))) (r-block (<- d (r-call ppcommand "ppdensend_reshape" x (r-call length value) (r-call as.real value) (r-call - dd 1))) (if (r-call == (r-call length ($ d shape)) 2) (r-call ppcommand "ppdensend_clobber_singletons_and_demote" d)) d))) ()))
|
||||
(<- length.darray (function ((*named* d *r-missing*)) (r-call prod ($ d shape)) ()))
|
||||
(<- ppzeros (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_zeros" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "zeros"))) ()))
|
||||
(<- ppones (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_ones" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims) 1) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "ones"))) ()))
|
||||
(<- pprand (function ((*named* dims *r-missing*)) (r-block (if (r-call == (r-call length dims) 2) (r-call ppcommand "ppdense_rand" (r-call r-aref dims 1) (r-call r-aref dims 2) (r-call dimdis dims)) (r-call ppcommand "ppdensend_add" (r-call - (r-call dimdis dims) 1) (r-call as.real dims) 1 "rand"))) ()))
|
||||
(<- ppback (function ((*named* m *r-missing*) (*named* dist (r-call dimdis (r-call dim m))) (*named* allowScalar *r-false*)) (r-block (if (\|\| (r-call is.darray m) (r-call == (r-call length m) 0)) (return m)) (<- lg (r-call is.logical m)) (if (&& (r-call ! (r-call is.complex m)) (r-call ! (r-call is.real m))) (r-block (if (r-call is.vector m) (<- m (r-call as.real m)) (<- m (r-call dim<- (r-call as.real m) (r-call dim m)))))) (if (r-call is.scalar m) (r-block (if allow\Scalar (return (r-call ppcommand "ppdensend_ppback_scalar" m))) (return m))) (if (r-call ! (missing dist)) (<- dist (r-call validdist dist))) (if (&& (r-call ! (r-call is.vector m)) (r-call == (r-call length (r-call dim m)) 2)) (<- d (r-call ppcommand "pp_dense_ppback" m (r-call r-index (r-call dim m) 1) (r-call r-index (r-call dim m) 2) dist)) (<- d (r-call ppcommand "ppdensend_ppback" (r-call - dist 1) (r-call as.real (r-call vdim m)) (r-call is.real m) m))) (if lg (<- ($ d logical) *r-true*)) d) ()))
|
||||
(<- ppfront (function ((*named* da *r-missing*)) (r-block (if (r-call ! (r-call is.darray da)) (return da)) (if (r-call == (r-call length ($ da shape)) 2) (r-block (<- l (r-call ppcommand "ppdense_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical (r-call r-aref l 1))) (<- m (r-call r-aref l 1))) (<- (r-call dim m) (r-call c (r-call r-aref l 2) (r-call r-aref l 3)))) (r-block (<- m (r-call ppcommand "ppdensend_ppfront" da)) (if ($ da logical) (<- m (r-call as.logical m))) (<- (r-call dim m) (r-call as.vector ($ da shape))))) m) ()))
|
||||
(<- vector (function ((*named* mode "logical") (*named* length 0)) (r-call \Use\Method "vector" length) ()))
|
||||
(<- vector.default (r-call .\Primitive "vector"))
|
||||
(<- vector.dlayout (function ((*named* mode "logical") (*named* length 0)) (r-block (<- d (r-call ppzeros (r-call c 1 length))) (if (r-call == mode "logical") (<- ($ d logical) *r-true*)) d) ()))
|
||||
(<- double (function ((*named* length 0)) (r-call vector "double" length) ()))
|
||||
(<- logical (function ((*named* length 0)) (r-call vector "logical" length) ()))
|
||||
(<- c (function ((*named* ... *r-missing*)) (r-block (<- args (r-call list r-dotdotdot)) (<- v (r-call (r-call .\Primitive "c") r-dotdotdot)) (<- l (r-call length args)) (if (r-call == l 0) (return v)) (for i (r-call : 1 l) (if (r-call is.dlayout (r-call r-aref args i)) (r-block (<- (r-call class v) (r-call append "dlayoutn" (r-call to\String i) (r-call class v))) (return v)))) v) ()))
|
||||
(<- rep (function ((*named* x *r-missing*) (*named* times 1) (*named* length.out \N\A) (*named* each 1)) (r-block (if (r-call is.darray x) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (if (\|\| (&& (missing length.out) (r-call > (r-call length times) 1)) (r-call > each 1)) (<- x (r-call ppfront x)))) (if (r-call ! (\|\| (r-call is.dlayout times) (&& (r-call ! (missing length.out)) (r-call is.dlayout length.out)))) (r-block (return (r-call (r-call .\Primitive "rep") x (*named* times times) (*named* length.out length.out) (*named* each each)))))) (if (r-call > each 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* each each))))) (if (missing length.out) (r-block (if (r-call > (r-call length times) 1) (r-block (<- x (r-call (r-call .\Primitive "rep") x (*named* times times))) (<- times 1)))) (r-block (<- times (r-call ceiling (r-call / length.out (r-call length x)))))) (if (r-call == (r-call length x) 1) (r-block (return (r-call * (r-call ppones (r-call r-aref times 1)) (r-call r-aref x 1))))) (<- x (r-call ppback (r-call as.2d x))) (<- out (r-call ppcommand "ppdense_repmat" x 1 (r-call r-aref times 1) 1)) (if (&& (r-call ! (missing length.out)) (r-call != (r-call r-aref (r-call dim out) 2) length.out)) (r-block (<- out (r-call ppcommand "ppdense_subsref_col" out (r-call as.realarray (r-call : 1 length.out)))))) (<- (r-call dim out) (r-call length out)) (return out)) ()))
|
||||
(<- globalbinding (function ((*named* sym *r-missing*)) (r-call eval (r-call as.name sym) (*named* envir (r-call globalenv))) ()))
|
||||
(<- boundp (function ((*named* sym *r-missing*)) (return (r-call != (r-call class (r-call try (r-call globalbinding sym) (*named* silent *r-true*))) "try-error")) ()))
|
||||
(<- redefining (function ((*named* sym *r-missing*)) (r-block (<- name (r-call deparse (substitute sym))) (<- rname (r-call paste "R" name (*named* sep ""))) (if (r-call ! (r-call boundp rname)) (r-call assign rname (r-call globalbinding name) (*named* envir (r-call globalenv))))) ()))
|
||||
(r-call redefining array)
|
||||
(<- array (function ((*named* data \N\A) (*named* dim (r-call length data)) (*named* dimnames ())) (r-block (<- dd *r-false*) (if (r-call == (r-call r-index (r-call class dim) 1) "dlayoutn") (<- dd (r-call as.numeric (r-call r-index (r-call class dim) 2)))) (if (r-call is.darray data) (r-block (if (r-call != (r-call length data) (r-call prod dim)) (r-block (<- data (r-call rep data (*named* length.out (r-call prod dim)))))) (if (r-call all (r-call == dim (r-call as.vector ($ data shape)))) (return data)) (return (r-call dim<-.darray data dim))) (r-block (if dd (r-block (<- data (r-call rep data (*named* length.out (r-call * (r-call prod dim) p)))) (return (r-call dim<-.darray data dim))) (r-block (r-call \Rarray data dim dimnames)))))) ()))
|
||||
(r-call redefining matrix)
|
||||
(<- matrix (function ((*named* data \N\A) (*named* nrow 1) (*named* ncol 1) (*named* byrow *r-false*) (*named* dimnames ())) (r-block (<- l (r-call length data)) (if (missing nrow) (r-block (if (r-call ! (missing ncol)) (<- nrow (r-call / l ncol)) (r-block (<- nrow l) (<- ncol 1)))) (if (missing ncol) (<- ncol (r-call / l nrow)))) (<- m (r-call array data (r-call c nrow ncol) dimnames)) (if byrow (r-call t m) m)) ()))
|
||||
(<- t.darray (function ((*named* da *r-missing*)) (r-block (if (\|\| (r-call == (r-call darraydist da) 1) (r-call == (r-call darraydist da) 2)) (r-call ppcommand "ppdense_transpose" da 0) (r-call ppcommand "pppblas_trans" da))) ()))
|
||||
(<- runif (function ((*named* n *r-missing*) (*named* min 0) (*named* max 1)) (r-block (if (r-call is.dlayout n) (r-call pprand n) (r-call .\Internal (r-call runif n min max)))) ()))
|
||||
(r-call redefining diag)
|
||||
(<- diag (function ((*named* da *r-missing*) (*named* nrow *r-missing*) (*named* ncol n)) (r-block (if (r-call is.darray da) (r-block (if (r-call == (r-call length ($ da shape)) 1) (r-block (<- da (r-call as.2d da)))) (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call == (r-call r-index ($ da shape) 1) 1) (return (r-call ppcommand "ppdense_diagv" da 0)) (if (r-call == (r-call r-index ($ da shape) 2) 1) (return (r-call ppcommand "ppdense_diagv" (r-call t da) 0)))))) (r-call t (r-call ppcommand "ppdense_diag" da 0))) (r-call \Rdiag da))) ()))
|
||||
(<- dbinaryop (function ((*named* code *r-missing*) (*named* scalarcode *r-missing*) (*named* bscalarcode *r-missing*) (*named* ndcode *r-missing*) (*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.scalar a) (r-block (if (r-call is.nd b) (r-call ppcommand "ppdensend_s_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" scalarcode a b))) (if (r-call is.scalar b) (r-block (if (r-call is.nd a) (r-call ppcommand "ppdensend_binary_operator_s" a b ndcode *r-true*) (r-call ppcommand "ppdense_scalar_op" bscalarcode b a))) (r-block (if (r-call ! (r-call is.darray a)) (<- a (r-call ppback a))) (if (r-call ! (r-call is.darray b)) (<- b (r-call ppback b))) (if (\|\| (r-call is.nd a) (r-call is.nd b)) (r-call ppcommand "ppdensend_binary_operator" a b ndcode *r-true*) (r-call ppcommand "ppdense_binary_op" code a b)))))) ()))
|
||||
(<- +.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 1 1 1 2 a b) ()))
|
||||
(<- *.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 3 3 3 3 a b) ()))
|
||||
(<- /.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 4 4 5 6 a b) ()))
|
||||
(<- ^.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-call dbinaryop 7 10 11 19 a b) ()))
|
||||
(<- mkdlogicalop (function ((*named* c *r-missing*) (*named* sc *r-missing*) (*named* bsc *r-missing*) (*named* ndcode *r-missing*)) (r-block (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (<- da (r-call dbinaryop c sc bsc ndcode a b)) (<- ($ da logical) *r-true*) da) ())) ()))
|
||||
(<- <.darray (r-call mkdlogicalop 14 16 17 15))
|
||||
(<- >.darray (r-call mkdlogicalop 15 17 16 17))
|
||||
(<- ==.darray (r-call mkdlogicalop 18 20 20 13))
|
||||
(<- !=.darray (r-call mkdlogicalop 19 21 21 14))
|
||||
(<- <=.darray (r-call mkdlogicalop 16 18 19 18))
|
||||
(<- >=.darray (r-call mkdlogicalop 17 19 18 16))
|
||||
(<- &.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppcopy a)) (return (r-call ppzeros (r-call dim a)))))) (<- da (r-call dbinaryop 11 (r-call - 1) (r-call - 1) 9 a b)) (<- ($ da logical) *r-true*) da) ()))
|
||||
(<- \|.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (<- other b) (r-block (<- other a) (<- a b))) (if (r-call is.scalar other) (r-block (if other (return (r-call ppones (r-call dim a))) (return (r-call ppcopy a))))) (<- da (r-call dbinaryop 12 (r-call - 1) (r-call - 1) 10 a b)) (<- ($ da logical) *r-true*) da) ()))
|
||||
(<- !.darray (function ((*named* a *r-missing*)) (r-block (if (r-call is.nd a) (r-block (<- da (r-call ppcommand "ppdensend_not" a))) (r-block (<- da (r-call ppcommand "ppdense_unary_op" 2 a)))) (<- ($ da logical) *r-true*) da) ()))
|
||||
(<- %*% (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (r-call is.darray a) (r-block (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" a b)) (r-block (r-call ppcommand "pppblas_gemm" a (r-call ppback b))))) (if (r-call is.darray b) (r-block (r-call ppcommand "pppblas_gemm" (r-call ppback a) b)) (r-call (r-call .\Primitive "%*%") a b)))) ()))
|
||||
(<- -.darray (function ((*named* a *r-missing*) (*named* b *r-missing*)) (r-block (if (missing b) (if (r-call is.nd a) (r-block (<- b a) (<- a 0)) (r-block (return (r-call ppcommand "ppdense_unary_op" 13 a))))) (if (r-call is.scalar b) (r-call dbinaryop 1 1 1 4 (r-call - b) a) (r-call dbinaryop 2 2 2 4 a b))) ()))
|
||||
(<- ppreduce (function ((*named* da *r-missing*) (*named* axis *r-missing*) (*named* allfunc *r-missing*) (*named* axisfunc *r-missing*) (*named* ndcode *r-missing*) (*named* islogical *r-false*)) (r-block (<- nd (r-call length ($ da shape))) (if (r-call == nd 2) (r-block (if (r-call ! axis) (r-call ppcommand allfunc da) (r-block (<- res (r-call ppcommand axisfunc da axis)) (if (r-call is.list res) (<- res (r-call r-aref res 1))) (return res)))) (r-block (if (r-call ! axis) (r-block (<- (r-call dim da) (r-call length da)) (<- axis 1))) (<- res (r-call ppcommand "ppdensend_reduce" da ndcode (r-call - axis 1))) (if (&& islogical (r-call is.darray res)) (<- ($ res logical) *r-true*)) (return res)))) ()))
|
||||
(<- any.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call > (r-call ppcommand "ppbase_nnz" da) 0))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_any" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 5 *r-true*)))) ()))
|
||||
(<- all.darray (function ((*named* da *r-missing*) (*named* axis *r-false*) (*named* na.rm *r-false*)) (r-block (if (r-call == (r-call length ($ da shape)) 2) (r-block (if (r-call ! axis) (r-block (return (r-call == (r-call ppcommand "ppbase_nnz" da) (r-call length da)))) (r-block (if (r-call == (r-call r-index ($ da shape) axis) 1) (return (r-call != da 0)) (r-block (<- res (r-call ppcommand "ppdense_all" da axis)) (<- ($ res logical) *r-true*) (return res)))))) (r-block (r-call ppreduce da axis "" "" 6 *r-true*)))) ()))
|
||||
(<- sum (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 0)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_sumv" "ppdense_sum" 2) (r-call (r-call .\Primitive "sum") r-dotdotdot (*named* na.rm na.rm)))) ()))
|
||||
(<- prod (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return 1)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_prodv" "ppdense_prod" 3) (r-call (r-call .\Primitive "prod") r-dotdotdot (*named* na.rm na.rm)))) ()))
|
||||
(<- min (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return \Inf)) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_minv" "ppdense_min" 8) (r-call (r-call .\Primitive "min") r-dotdotdot (*named* na.rm na.rm)))) ()))
|
||||
(<- max (function ((*named* ... *r-missing*) (*named* na.rm *r-false*) (*named* axis *r-false*)) (r-block (<- l (r-call list r-dotdotdot)) (if (r-call == (r-call length l) 0) (return (r-call - \Inf))) (<- da (r-call r-aref l 1)) (if (r-call is.darray da) (r-call ppreduce da axis "ppdense_maxv" "ppdense_max" 7) (r-call (r-call .\Primitive "max") r-dotdotdot (*named* na.rm na.rm)))) ()))
|
||||
(<- ppcopy (function ((*named* d *r-missing*) (*named* dist 2)) (r-block (if (\|\| (missing dist) (r-call == dist (r-call darraydist d))) (return (r-call ppcommand "ppbase_createMatrixCopy" d)) (return (r-call ppcommand "ppbase_createMatrixCopyRedist" d dist)))) ()))
|
||||
(<- as.realarray (function ((*named* x *r-missing*)) (r-call as.array (r-call as.real x)) ()))
|
||||
(<- as.1d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call length x)) (return x)) ()))
|
||||
(<- as.2d (function ((*named* x *r-missing*)) (r-block (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ()))
|
||||
(<- as.real2d (function ((*named* x *r-missing*)) (r-block (<- x (r-call as.real x)) (<- (r-call dim x) (r-call c 1 (r-call length x))) (return x)) ()))
|
||||
(<- to\Index\Vec2d (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdense_zeros" 1 0 1)))) (return (r-call ppback (r-call as.2d i) (*named* allowScalar *r-true*)))) ()))
|
||||
(<- to\Index\Vec (function ((*named* i *r-missing*) (*named* con *r-missing*)) (r-block (if (r-call == (r-call length i) 0) (r-block (return (r-call ppcommand "ppdensend_add" 0 0 1 "zeros")))) (return (r-call ppback i (*named* allowScalar *r-true*)))) ()))
|
||||
(<- to\Num\Index (function ((*named* i *r-missing*)) (r-block (if (r-call ! (r-call is.darray i)) (r-block (if (r-call is.logical i) (r-block (<- \N (r-call : 1 (r-call length i))) (<- i (r-call r-index \N i)))) (return i)) (if (r-call ! ($ i logical)) (r-block (return i)))) (if (r-call != (r-call length (r-call dim i)) 2) (<- (r-call dim i) (r-call c 1 (r-call length i)))) (<- i (r-call r-aref (r-call ppcommand "ppdense_find" i 1 0 0) 1)) (<- (r-call dim i) (r-call length i)) i) ()))
|
||||
(<- expand\Linear\Index (function ((*named* shape *r-missing*) (*named* i *r-missing*)) (r-block (<- out (r-call numeric (r-call length shape))) (for n (r-call : 1 (r-call length shape)) (r-block (<- (r-call r-aref out n) (r-call + (r-call %% (r-call - i 1) (r-call r-index shape n)) 1)) (<- i (r-call + (r-call %/% (r-call - i 1) (r-call r-index shape n)) 1)))) out) ()))
|
||||
(<- to\Linear\Index (function ((*named* shape *r-missing*) (*named* iv *r-missing*)) (r-call + (r-call sum (r-call * (r-call - iv 1) (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))))) 1) ()))
|
||||
(<- to\Linear\Indexes (function ((*named* shape *r-missing*) (*named* im *r-missing*)) (r-block (<- ds (r-call t (r-call array (r-call cumprod (r-call r-index (r-call c 1 shape) (r-call - (r-call - (r-call length shape)) 1))) (r-call rev (r-call dim im))))) (r-call as.1d (r-call + (r-call apply (r-call * (r-call - im 1) ds) 1 sum) 1))) ()))
|
||||
(<- starpcolon (quote :missingarg:))
|
||||
(<- is.colon (function ((*named* x *r-missing*)) (r-call identical x starpcolon) ()))
|
||||
(<- normalize\Indexes (function ((*named* shape *r-missing*) (*named* idxs *r-missing*)) (r-block (<- li (r-call length idxs)) (<- out (r-call vector "list" li)) (if (r-call == li 0) (return out) (if (&& (r-call > li 1) (r-call != li (r-call length shape))) (r-call stop "wrong number of subscripts"))) (for n (r-call : 1 li) (r-block (<- i (r-call r-aref idxs n)) (if (r-call == (r-call length (r-call dim i)) 2) (r-block (<- i (r-call to\Linear\Indexes shape i)) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i)))))) (if (r-call ! (r-call is.colon i)) (r-block (if (r-call > (r-call length (r-call dim i)) 2) (r-block (<- i (r-call as.1d i)))) (<- lg (\|\| (r-call is.logical i) (&& (r-call is.darray i) ($ i logical)))) (if (&& lg (r-call == li 1)) (<- i (r-call rep i (*named* length.out (r-call prod shape))))) (<- i (r-call to\Num\Index i)) (if (r-call ! lg) (r-block (<- nonz (r-call != i 0)) (if (r-call ! (r-call is.darray nonz)) (r-block (<- i (r-call r-index i nonz))) (r-block (<- where (r-call r-aref (r-call ppcommand "ppdense_find" (r-call as.2d i) 1 0 0) 1)) (<- i (r-call ppcommand "ppdense_subsref_dcol" i where)))))) (if (r-call == (r-call length i) 1) (<- i (r-call as.real (r-call as.vector (r-call ppfront i))))) (if (&& (r-call is.scalar i) (r-call < i 0)) (r-block (<- i (r-call r-index (r-call : 1 (r-call r-index shape n)) i))))))) (<- (r-call r-aref out n) i))) out) ()))
|
||||
(<- index\Sizes (function ((*named* d *r-missing*) (*named* idxs *r-missing*)) (r-block (<- n (r-call length idxs)) (<- whichcolons (r-call logical n)) (<- lens (r-call numeric n)) (for i (r-call : 1 n) (r-block (if (r-call is.colon (r-call r-aref idxs i)) (r-block (<- (r-call r-index whichcolons i) *r-true*) (<- (r-call r-index lens i) (r-call r-index (r-call dim d) i))) (<- (r-call r-index lens i) (r-call length (r-call r-aref idxs i)))))) (r-call list lens whichcolons)) ()))
|
||||
(<- \[.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (if (r-call == n 1) (return d)) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call revealargs (r-call get "...")))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return (r-call array 0 (r-call r-index lens (r-call != lens 1)))))) (if (r-call all whichcolons) (return (r-call ppcopy d))) (if (r-call == n 2) (r-block (if (r-call == (r-call length (r-call dim d)) 2) (<- x (r-call ppcommand "ppdense_subsref_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))))) (<- x (r-call ppcommand "ppdensend_subsref_idx_dist" d (r-call ppback (r-call r-aref idxs 1) (*named* allowScalar *r-true*))))) (if (r-call == (r-call length (r-call r-aref idxs 1)) 1) (return (r-call ppfront x)) (return x))) (if (r-call == n 3) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (return (r-call ppcommand "ppdense_viewelement" d r c)))) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (<- a (r-call ppcommand "ppdense_subsref_dcol" d c)) (<- a (r-call ppcommand "ppdense_subsref_col" d (r-call as.realarray c))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (<- a (r-call ppcommand "ppdense_subsref_drow" d r)) (<- a (r-call ppcommand "ppdense_subsref_row" d (r-call as.realarray r))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (<- a (r-call ppcommand "ppdense_subsref_rowcol" d r c))))) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d a))) (return a)))) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (return (r-call ppcommand "ppdensend_subsref_scalar" d (r-call as.numeric idxs))))) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (if (r-call == slicepos (r-call darraydist d)) (r-block (if (r-call > (r-call length slice) 1) (r-block (<- (r-call dim slice) (r-call c (r-call length slice) 1)) (<- slice (r-call ppback slice)))) (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_dist" d slice))) (r-block (<- result (r-call ppcommand "ppdensend_subsref_extract_slices_local" d (r-call - slicepos 1) slice))))) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsref_element_list" (r-call append 0 idxs))) (<- (r-call r-aref al 2) d) (<- result (r-call ppvcommand al)) (if (r-call == (r-call sum (r-call > lens 1)) 1) (return (r-call as.1d result))))) (return result)) ()))
|
||||
(<- \[<-.darray (function ((*named* d *r-missing*) (*named* ... *r-missing*)) (r-block (<- n (r-call nargs)) (<- arglist (r-call revealargs (r-call get "..."))) (<- rhs (r-call r-aref arglist (r-call - n 1))) (<- idxs (r-call normalize\Indexes (r-call dim d) (r-call r-index arglist (r-call + (r-call - n) 1)))) (if (&& (r-call == (r-call length idxs) 1) (r-call is.colon (r-call r-aref idxs 1))) (r-block (<- idxs (r-call rep (r-call list starpcolon) (*named* length.out (r-call length (r-call dim d))))) (<- n (r-call + 2 (r-call length (r-call dim d)))))) (<- tmp (r-call index\Sizes d idxs)) (<- lens (r-call r-aref tmp 1)) (<- whichcolons (r-call r-aref tmp 2)) (if (r-call == (r-call prod lens) 0) (r-block (return d))) (if (r-call ! (r-call is.scalar rhs)) (r-block (if (&& (r-call != (r-call length rhs) (r-call prod lens)) (r-call > (r-call prod lens) 1)) (r-block (<- rhs (r-call rep rhs (*named* length.out (r-call prod lens)))))) (if (r-call is.darray rhs) (r-block (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs)))) (r-block (<- rhs (r-call as.array rhs)) (if (r-call == (r-call length (r-call dim rhs)) 1) (<- rhs (r-call as.2d rhs))) (<- rhs (r-call ppback rhs)))))) (if (r-call == (r-call length (r-call dim d)) 2) (r-block (if (r-call all whichcolons) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_setall" d rhs) (r-call ppcommand "ppdense_copyall" rhs d)) (if (r-call == n 3) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_idx_s" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (r-call ppcommand "ppdense_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) (r-call ppback rhs)))) (r-block (<- r (r-call r-aref idxs 1)) (<- c (r-call r-aref idxs 2)) (if (&& (r-call is.scalar r) (r-call is.scalar c)) (r-block (if (r-call ! (r-call is.scalar rhs)) (r-call stop "expected scalar value")) (r-call ppcommand "ppdense_setelement" d r c rhs)) (if (r-call is.colon r) (r-block (if (r-call is.darray c) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_dcol_s" d c rhs) (r-call ppcommand "ppdense_subsasgn_dcol" d c rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_col_s" d (r-call as.real2d c) rhs) (r-call ppcommand "ppdense_subsasgn_col" d (r-call as.real2d c) rhs))))) (if (r-call is.colon c) (r-block (if (r-call is.darray r) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_drow_s" d r rhs) (r-call ppcommand "ppdense_subsasgn_drow" d r rhs))) (r-block (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_row_s" d (r-call as.real2d r) rhs) (r-call ppcommand "ppdense_subsasgn_row" d (r-call as.real2d r) rhs))))) (r-block (if (r-call ! (r-call is.darray r)) (<- r (r-call as.realarray r))) (if (r-call ! (r-call is.darray c)) (<- c (r-call as.realarray c))) (if (r-call is.scalar rhs) (r-call ppcommand "ppdense_subsasgn_rowcol_s" d r c rhs) (r-call ppcommand "ppdense_subsasgn_rowcol" d r c rhs))))))))) (return d)) (r-block (if (r-call == n 3) (r-call ppcommand "ppdensend_subsasgn_idx" d (r-call ppback (r-call as.2d (r-call r-aref idxs 1))) rhs) (if (r-call all (r-call lapply idxs is.scalar)) (r-block (r-call ppcommand "ppdensend_subsasgn_scalar" d (r-call as.numeric idxs) rhs)) (if (r-call == (r-call sum whichcolons) (r-call - (r-call length (r-call dim d)) 1)) (r-block (<- slice (r-call as.realarray (r-call r-aref (r-call r-index idxs (r-call ! whichcolons)) 1))) (<- slicepos (r-call r-index (r-call : 1 (r-call length idxs)) (r-call ! whichcolons))) (r-call ppcommand "ppdensend_subsasgn_slice" d (r-call - slicepos 1) slice rhs)) (r-block (<- idxs (r-call lapply idxs (function ((*named* i *r-missing*)) (if (r-call is.colon i) (r-call - 1) (r-call as.realarray i)) ()))) (<- al (r-call append "ppdensend_subsasgn_tuple" (r-call append 0 (r-call append idxs 0)))) (<- (r-call r-aref al 2) d) (<- (r-call r-aref al (r-call length al)) rhs) (r-call ppvcommand al))))))) d) ()))
|
||||
(<- unaryops (r-call list (r-call list "ceiling" 9 "ceil") (r-call list "round" 10) (r-call list "floor" 11) (r-call list "sign" 14) (r-call list "abs" 15) (r-call list "sqrt" 16 *r-false*) (r-call list "exp" 17) (r-call list "log10" 19) (r-call list "log2" 20) (r-call list "Conj" 8 *r-false*) (r-call list "sin" 21) (r-call list "cos" 22) (r-call list "tan" 23)))
|
||||
(<- mkunaryop (function ((*named* code *r-missing*) (*named* oldf *r-missing*) (*named* ndname *r-missing*)) (r-block (r-call force code) (r-call force oldf) (if (r-call is.character ndname) (r-block (<- ndname (r-call paste "ppdensend_" ndname (*named* sep ""))) (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-block (if (r-call == (r-call length ($ x shape)) 2) (r-call ppcommand "ppdense_unary_op" code x) (r-call ppcommand ndname x))) (r-call oldf x))) ())) (r-block (function ((*named* x *r-missing*)) (r-block (if (r-call is.darray x) (r-call ppcommand "ppdense_unary_op" code x) (r-call oldf x))) ())))) ()))
|
||||
(for i unaryops (r-block (<- ppname (r-call as.name (r-call r-aref i 1))) (<- \Rf (r-call eval ppname)) (if (r-call == (r-call length i) 2) (<- ndn (r-call r-aref i 1)) (<- ndn (r-call r-aref i 3))) (r-call assign (r-call as.character ppname) (r-call mkunaryop (r-call r-aref i 2) \Rf ndn) (*named* envir (r-call globalenv)))))
|
||||
(r-call redefining chol)
|
||||
(<- chol (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_chol" m)) (if (r-call > (r-call r-aref l 1) 0) (r-call stop "chol: not positive definite.")) (return (r-call r-aref l 2)))) (r-call \Rchol m)) ()))
|
||||
(r-call redefining ginv)
|
||||
(<- ginv (function ((*named* m *r-missing*)) (r-block (if (r-call is.darray m) (r-block (<- l (r-call ppcommand "ppscalapack_inv" m)) (return (r-call r-aref l 1)))) (r-call \Rginv m)) ()))
|
||||
(r-call redefining eigen)
|
||||
(<- eigen (function ((*named* x *r-missing*) (*named* symmetric *r-missing*) (*named* only.values *r-false*) (*named* EISPACK *r-false*)) (r-block (if (r-call ! (r-call is.darray x)) (return (r-call \Reigen x symmetric only.values \E\I\S\P\A\C\K))) (if only.values (<- vl 0) (<- vl 1)) (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- res (r-call ppcommand "ppscalapack_eig_sym" x vl))) (r-block (<- res (r-call ppcommand "ppscalapack_eig" x vl)))) (<- out (r-call list (*named* values ()) (*named* vectors ()))) (if only.values (r-block (<- ($ out values) (r-call t res))) (r-block (if (&& (r-call ! (missing symmetric)) symmetric) (r-block (<- ($ out values) (r-call t (r-call r-aref res 2)))) (r-block (<- ($ out values) (r-call diag (r-call r-aref res 2))))) (<- ($ out vectors) (r-call r-aref res 1)))) out) ()))
|
||||
(r-call redefining apply)
|
||||
(<- apply (function ((*named* d *r-missing*) (*named* axis *r-missing*) (*named* f *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (return (r-call \Rapply d axis f))) (<- axis (r-call + axis 1)) (if (r-call identical f sum) (r-call t (r-call ppcommand "ppdense_sum" d axis)) (r-call stop "starp: unsupported operation"))) ()))
|
||||
(r-call redefining diag<-)
|
||||
(<- diag<- (function ((*named* d *r-missing*) (*named* value *r-missing*)) (r-block (if (r-call ! (r-call is.darray d)) (r-block (if (r-call is.darray value) (<- value (r-call ppfront value))) (return (r-call \Rdiag<- d value)))) (if (r-call != (r-call length (r-call dim d)) 2) (r-call stop "starp diag<-: only supported for 2d")) (<- n (r-call min (r-call dim d))) (<- idxs (r-call ppcommand "ppdense_makeRange" 1 (r-call + (r-call r-index (r-call dim d) 1) 1) (r-call + (r-call * (r-call - n 1) (r-call r-index (r-call dim d) 1)) n))) (if (r-call is.scalar value) (r-block (r-call ppcommand "ppdense_subsasgn_idx_s" d idxs value)) (if (r-call != (r-call length value) n) (r-block (r-call stop "diag<-: replacement diagonal has wrong length")) (r-block (r-call ppcommand "ppdense_subsasgn_idx" d idxs (r-call ppback (r-call as.2d value)))))) d) ()))
|
||||
(<- engine\Arg (function ((*named* arg *r-missing*)) (r-block (<- arg (r-call tolower arg)) (if (r-call != arg "") (r-block (if (r-call != arg "c") (r-call stop "unknown engine specified")))) (return arg)) ()))
|
||||
(<- pploadcenginemodule (function ((*named* filename *r-missing*) (*named* name "")) (r-block (<- res (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:load_module" 1 0 filename name)) (return (r-call r-aref (r-call ppcommand "ppemode2_getelement" (r-call r-index (r-call r-aref res 1) 1) 0) 2))) ()))
|
||||
(<- ppunloadcenginemodule (function ((*named* name *r-missing*)) (r-block (r-call ppcommand "ppemode2_evaluate" "c" "ppevalc_builtin:remove_module" 1 0 name) *r-true*) ()))
|
||||
(<- pploadpackage (function ((*named* filename *r-missing*) (*named* name "") (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call pploadcenginemodule filename (*named* name name)) (r-block (<- out (r-call ppcommand "ppbase_loadUserPackage" filename name)) (if (r-call > (r-call length out) 1) (r-block (r-call warning (r-call r-index out 2)) (return (r-call r-index out 1)))) (return out)))) ()))
|
||||
(<- ppunloadpackage (function ((*named* name *r-missing*) (*named* engine "")) (r-block (<- engine (r-call engine\Arg engine)) (if (r-call == engine "c") (r-call ppunloadcenginemodule name) (r-call ppcommand "ppbase_removeUserPackage" name)) *r-true*) ())))
|
||||
|
|
@ -0,0 +1,511 @@
|
|||
; femtoLisp standard library
|
||||
; by Jeff Bezanson
|
||||
; Public Domain
|
||||
|
||||
(set 'list (lambda args args))
|
||||
|
||||
(set 'setq (macro (name val)
|
||||
(list set (list 'quote name) val)))
|
||||
|
||||
(setq sp '| |)
|
||||
(setq nl '|
|
||||
|)
|
||||
|
||||
; convert a sequence of body statements to a single expression.
|
||||
; this allows define, defun, defmacro, let, etc. to contain multiple
|
||||
; body expressions as in Common Lisp.
|
||||
(setq f-body (lambda (e)
|
||||
(cond ((atom e) e)
|
||||
((eq (cdr e) ()) (car e))
|
||||
(T (cons 'progn e)))))
|
||||
|
||||
(setq defmacro
|
||||
(macro (name args . body)
|
||||
(list 'setq name (list 'macro args (f-body body)))))
|
||||
|
||||
; support both CL defun and Scheme-style define
|
||||
(defmacro defun (name args . body)
|
||||
(list 'setq name (list 'lambda args (f-body body))))
|
||||
|
||||
(defmacro define (name . body)
|
||||
(if (symbolp name)
|
||||
(list 'setq name (car body))
|
||||
(cons 'defun (cons (car name) (cons (cdr name) body)))))
|
||||
|
||||
(defun identity (x) x)
|
||||
(setq null not)
|
||||
(defun consp (x) (not (atom x)))
|
||||
|
||||
(defun map (f lst)
|
||||
(if (atom lst) lst
|
||||
(cons (f (car lst)) (map f (cdr lst)))))
|
||||
|
||||
(defmacro let (binds . body)
|
||||
(cons (list 'lambda
|
||||
(map (lambda (c) (if (consp c) (car c) c)) binds)
|
||||
(f-body body))
|
||||
(map (lambda (c) (if (consp c) (cadr c) nil)) binds)))
|
||||
|
||||
(defun nconc lsts
|
||||
(cond ((null lsts) ())
|
||||
((null (cdr lsts)) (car lsts))
|
||||
(T ((lambda (l d) (if (null l) d
|
||||
(prog1 l
|
||||
(while (consp (cdr l)) (set 'l (cdr l)))
|
||||
(rplacd l d))))
|
||||
(car lsts) (apply nconc (cdr lsts))))))
|
||||
|
||||
(defun append lsts
|
||||
(cond ((null lsts) ())
|
||||
((null (cdr lsts)) (car lsts))
|
||||
(T ((label append2 (lambda (l d)
|
||||
(if (null l) d
|
||||
(cons (car l)
|
||||
(append2 (cdr l) d)))))
|
||||
(car lsts) (apply append (cdr lsts))))))
|
||||
|
||||
(defun member (item lst)
|
||||
(cond ((atom lst) ())
|
||||
((equal (car lst) item) lst)
|
||||
(T (member item (cdr lst)))))
|
||||
|
||||
(defun macrop (e) (and (consp e) (eq (car e) 'macro) e))
|
||||
(defun macrocallp (e) (and (symbolp (car e))
|
||||
(boundp (car e))
|
||||
(macrop (eval (car e)))))
|
||||
(defun macroapply (m args) (apply (cons 'lambda (cdr m)) args))
|
||||
|
||||
(defun macroexpand-1 (e)
|
||||
(if (atom e) e
|
||||
(let ((f (macrocallp e)))
|
||||
(if f (macroapply f (cdr e))
|
||||
e))))
|
||||
|
||||
; convert to proper list, i.e. remove "dots", and append
|
||||
(defun append.2 (l tail)
|
||||
(cond ((null l) tail)
|
||||
((atom l) (cons l tail))
|
||||
(T (cons (car l) (append.2 (cdr l) tail)))))
|
||||
|
||||
(define (cadr x) (car (cdr x)))
|
||||
|
||||
(defun macroexpand (e)
|
||||
((label mexpand
|
||||
(lambda (e env f)
|
||||
(progn
|
||||
(while (and (consp e)
|
||||
(not (member (car e) env))
|
||||
(set 'f (macrocallp e)))
|
||||
(set 'e (macroapply f (cdr e))))
|
||||
(if (and (consp e)
|
||||
(not (eq (car e) 'quote)))
|
||||
(let ((newenv
|
||||
(if (and (or (eq (car e) 'lambda) (eq (car e) 'macro))
|
||||
(consp (cdr e)))
|
||||
(append.2 (cadr e) env)
|
||||
env)))
|
||||
(map (lambda (x) (mexpand x newenv nil)) e))
|
||||
e))))
|
||||
e nil nil))
|
||||
|
||||
; uncomment this to macroexpand functions at definition time.
|
||||
; makes typical code ~25% faster, but only works for defun expressions
|
||||
; at the top level.
|
||||
(defmacro defun (name args . body)
|
||||
(list 'setq name (list 'lambda args (macroexpand (f-body body)))))
|
||||
|
||||
; same thing for macros. enabled by default because macros are usually
|
||||
; defined at the top level.
|
||||
(defmacro defmacro (name args . body)
|
||||
(list 'setq name (list 'macro args (macroexpand (f-body body)))))
|
||||
|
||||
(setq = eq)
|
||||
(setq eql eq)
|
||||
(define (/= a b) (not (eq a b)))
|
||||
(define != /=)
|
||||
(define (> a b) (< b a))
|
||||
(define (<= a b) (not (< b a)))
|
||||
(define (>= a b) (not (< a b)))
|
||||
(define (1+ n) (+ n 1))
|
||||
(define (1- n) (- n 1))
|
||||
(define (mod x y) (- x (* (/ x y) y)))
|
||||
(define (abs x) (if (< x 0) (- x) x))
|
||||
(define (truncate x) x)
|
||||
(setq K prog1) ; K combinator ;)
|
||||
(define (funcall f . args) (apply f args))
|
||||
(define (symbol-function sym) (eval sym))
|
||||
(define (symbol-value sym) (eval sym))
|
||||
|
||||
(define (caar x) (car (car x)))
|
||||
(define (cdar x) (cdr (car x)))
|
||||
(define (cddr x) (cdr (cdr x)))
|
||||
(define (caaar x) (car (car (car x))))
|
||||
(define (caadr x) (car (car (cdr x))))
|
||||
(define (cadar x) (car (cdr (car x))))
|
||||
(define (caddr x) (car (cdr (cdr x))))
|
||||
(define (cdaar x) (cdr (car (car x))))
|
||||
(define (cdadr x) (cdr (car (cdr x))))
|
||||
(define (cddar x) (cdr (cdr (car x))))
|
||||
(define (cdddr x) (cdr (cdr (cdr x))))
|
||||
|
||||
(define (equal a b)
|
||||
(if (and (consp a) (consp b))
|
||||
(and (equal (car a) (car b))
|
||||
(equal (cdr a) (cdr b)))
|
||||
(eq a b)))
|
||||
|
||||
; compare imposes an ordering on all values. yields -1 for a<b,
|
||||
; 0 for a==b, and 1 for a>b. lists are compared up to the first
|
||||
; point of difference.
|
||||
(defun compare (a b)
|
||||
(cond ((eq a b) 0)
|
||||
((or (atom a) (atom b)) (if (< a b) -1 1))
|
||||
(T (let ((c (compare (car a) (car b))))
|
||||
(if (not (eq c 0))
|
||||
c
|
||||
(compare (cdr a) (cdr b)))))))
|
||||
|
||||
(defun every (pred lst)
|
||||
(or (atom lst)
|
||||
(and (pred (car lst))
|
||||
(every pred (cdr lst)))))
|
||||
|
||||
(defun any (pred lst)
|
||||
(and (consp lst)
|
||||
(or (pred (car lst))
|
||||
(any pred (cdr lst)))))
|
||||
|
||||
(defun listp (a) (or (eq a ()) (consp a)))
|
||||
|
||||
(defun length (l)
|
||||
(if (null l) 0
|
||||
(+ 1 (length (cdr l)))))
|
||||
|
||||
(defun nthcdr (n lst)
|
||||
(if (<= n 0) lst
|
||||
(nthcdr (- n 1) (cdr lst))))
|
||||
|
||||
(defun list-ref (lst n)
|
||||
(car (nthcdr n lst)))
|
||||
|
||||
(defun list* l
|
||||
(if (atom (cdr l))
|
||||
(car l)
|
||||
(cons (car l) (apply list* (cdr l)))))
|
||||
|
||||
(defun nlist* l
|
||||
(if (atom (cdr l))
|
||||
(car l)
|
||||
(rplacd l (apply nlist* (cdr l)))))
|
||||
|
||||
(defun lastcdr (l)
|
||||
(if (atom l) l
|
||||
(lastcdr (cdr l))))
|
||||
|
||||
(defun last (l)
|
||||
(cond ((atom l) l)
|
||||
((atom (cdr l)) l)
|
||||
(T (last (cdr l)))))
|
||||
|
||||
(defun map! (f lst)
|
||||
(prog1 lst
|
||||
(while (consp lst)
|
||||
(rplaca lst (f (car lst)))
|
||||
(set 'lst (cdr lst)))))
|
||||
|
||||
(defun mapcar (f . lsts)
|
||||
((label mapcar-
|
||||
(lambda (lsts)
|
||||
(cond ((null lsts) (f))
|
||||
((atom (car lsts)) (car lsts))
|
||||
(T (cons (apply f (map car lsts))
|
||||
(mapcar- (map cdr lsts)))))))
|
||||
lsts))
|
||||
|
||||
(defun transpose (M) (apply mapcar (cons list M)))
|
||||
|
||||
(defun filter (pred lst)
|
||||
(cond ((null lst) ())
|
||||
((not (pred (car lst))) (filter pred (cdr lst)))
|
||||
(T (cons (car lst) (filter pred (cdr lst))))))
|
||||
|
||||
(define (foldr f zero lst)
|
||||
(if (null lst) zero
|
||||
(f (car lst) (foldr f zero (cdr lst)))))
|
||||
|
||||
(define (foldl f zero lst)
|
||||
(if (null lst) zero
|
||||
(foldl f (f (car lst) zero) (cdr lst))))
|
||||
|
||||
(define (reverse lst) (foldl cons nil lst))
|
||||
|
||||
(defun reduce (f zero lst)
|
||||
(if (null lst) zero
|
||||
(reduce f (f zero (car lst)) (cdr lst))))
|
||||
|
||||
(define (copy-list l)
|
||||
(if (atom l) l
|
||||
(cons (car l)
|
||||
(copy-list (cdr l)))))
|
||||
(define (copy-tree l)
|
||||
(if (atom l) l
|
||||
(cons (copy-tree (car l))
|
||||
(copy-tree (cdr l)))))
|
||||
|
||||
(define (assoc item lst)
|
||||
(cond ((atom lst) ())
|
||||
((eq (caar lst) item) (car lst))
|
||||
(T (assoc item (cdr lst)))))
|
||||
|
||||
(define (nreverse l)
|
||||
(let ((prev nil))
|
||||
(while (consp l)
|
||||
(set 'l (prog1 (cdr l)
|
||||
(rplacd l (prog1 prev
|
||||
(set 'prev l))))))
|
||||
prev))
|
||||
|
||||
(defmacro let* (binds . body)
|
||||
(cons (list 'lambda (map car binds)
|
||||
(cons 'progn
|
||||
(nconc (map (lambda (b) (cons 'setq b)) binds)
|
||||
body)))
|
||||
(map (lambda (x) nil) binds)))
|
||||
|
||||
(defmacro labels (binds . body)
|
||||
(cons (list 'lambda (map car binds)
|
||||
(cons 'progn
|
||||
(nconc (map (lambda (b)
|
||||
(list 'setq (car b) (cons 'lambda (cdr b))))
|
||||
binds)
|
||||
body)))
|
||||
(map (lambda (x) nil) binds)))
|
||||
|
||||
(defmacro when (c . body) (list if c (f-body body) nil))
|
||||
(defmacro unless (c . body) (list if c nil (f-body body)))
|
||||
|
||||
(defmacro dotimes (var . body)
|
||||
(let ((v (car var))
|
||||
(cnt (cadr var)))
|
||||
(list 'let (list (list v 0))
|
||||
(list 'while (list < v cnt)
|
||||
(list prog1 (f-body body) (list 'setq v (list + v 1)))))))
|
||||
|
||||
(defun map-int (f n)
|
||||
(let ((acc nil))
|
||||
(dotimes (i n)
|
||||
(setq acc (cons (f i) acc)))
|
||||
(nreverse acc)))
|
||||
|
||||
(defun error args (raise (cons 'error args)))
|
||||
|
||||
(defmacro throw (tag value) `(raise (list 'thrown-value ,tag ,value)))
|
||||
(defmacro catch (tag expr)
|
||||
(let ((e (gensym)))
|
||||
`(trycatch ,expr
|
||||
(lambda (,e) (if (and (consp ,e)
|
||||
(eq (car ,e) 'thrown-value)
|
||||
(eq (cadr ,e) ,tag))
|
||||
(caddr ,e)
|
||||
(raise ,e))))))
|
||||
|
||||
(defmacro unwind-protect (expr finally)
|
||||
(let ((e (gensym)))
|
||||
`(prog1 (trycatch ,expr
|
||||
(lambda (,e) (progn ,finally (raise ,e))))
|
||||
,finally)))
|
||||
|
||||
; (try expr
|
||||
; (catch (type-error e) . exprs)
|
||||
; (catch (io-error e) . exprs)
|
||||
; (catch (e) . exprs)
|
||||
; (finally . exprs))
|
||||
(defmacro try (expr . forms)
|
||||
(let* ((e (gensym))
|
||||
(reraised (gensym))
|
||||
(final (f-body (cdr (or (assoc 'finally forms) '(())))))
|
||||
(catches (filter (lambda (f) (eq (car f) 'catch)) forms))
|
||||
(catchblock `(cond
|
||||
,.(map (lambda (catc)
|
||||
(let* ((specific (cdr (cadr catc)))
|
||||
(extype (caadr catc))
|
||||
(var (if specific (car specific)
|
||||
extype))
|
||||
(todo (cddr catc)))
|
||||
`(,(if specific
|
||||
; exception matching logic
|
||||
`(or (eq ,e ',extype)
|
||||
(and (consp ,e)
|
||||
(eq (car ,e)
|
||||
',extype)))
|
||||
T); (catch (e) ...), match anything
|
||||
(let ((,var ,e)) ,@todo))))
|
||||
catches)
|
||||
(T (raise ,e))))) ; no matches, reraise
|
||||
(if final
|
||||
(if catches
|
||||
; form with both catch and finally
|
||||
`(prog1 (trycatch ,expr
|
||||
(lambda (,e)
|
||||
(trycatch ,catchblock
|
||||
(lambda (,reraised)
|
||||
(progn ,final
|
||||
(raise ,reraised))))))
|
||||
,final)
|
||||
; finally only; same as unwind-protect
|
||||
`(prog1 (trycatch ,expr (lambda (,e)
|
||||
(progn ,final (raise ,e))))
|
||||
,final))
|
||||
; catch, no finally
|
||||
`(trycatch ,expr (lambda (,e) ,catchblock)))))
|
||||
|
||||
; property lists
|
||||
(setq *plists* nil)
|
||||
|
||||
(defun symbol-plist (sym)
|
||||
(cdr (or (assoc sym *plists*) '(()))))
|
||||
|
||||
(defun set-symbol-plist (sym lst)
|
||||
(let ((p (assoc sym *plists*)))
|
||||
(if (null p) ; sym has no plist yet
|
||||
(setq *plists* (cons (cons sym lst) *plists*))
|
||||
(rplacd p lst))))
|
||||
|
||||
(defun get (sym prop)
|
||||
(let ((pl (symbol-plist sym)))
|
||||
(if pl
|
||||
(let ((pr (member prop pl)))
|
||||
(if pr (cadr pr) nil))
|
||||
nil)))
|
||||
|
||||
(defun put (sym prop val)
|
||||
(let ((p (assoc sym *plists*)))
|
||||
(if (null p) ; sym has no plist yet
|
||||
(setq *plists* (cons (list sym prop val) *plists*))
|
||||
(let ((pr (member prop p)))
|
||||
(if (null pr) ; sym doesn't have this property yet
|
||||
(rplacd p (cons prop (cons val (cdr p))))
|
||||
(rplaca (cdr pr) val)))))
|
||||
val)
|
||||
|
||||
; setf
|
||||
; expands (setf (place x ...) v) to (mutator (f x ...) v)
|
||||
; (mutator (identity x ...) v) is interpreted as (mutator x ... v)
|
||||
(setq *setf-place-list*
|
||||
; place mutator f
|
||||
'((car rplaca identity)
|
||||
(cdr rplacd identity)
|
||||
(caar rplaca car)
|
||||
(cadr rplaca cdr)
|
||||
(cdar rplacd car)
|
||||
(cddr rplacd cdr)
|
||||
(caaar rplaca caar)
|
||||
(caadr rplaca cadr)
|
||||
(cadar rplaca cdar)
|
||||
(caddr rplaca cddr)
|
||||
(cdaar rplacd caar)
|
||||
(cdadr rplacd cadr)
|
||||
(cddar rplacd cdar)
|
||||
(cdddr rplacd cddr)
|
||||
(get put identity)
|
||||
(aref aset identity)
|
||||
(symbol-function set identity)
|
||||
(symbol-value set identity)
|
||||
(symbol-plist set-symbol-plist identity)))
|
||||
|
||||
(defun setf-place-mutator (place val)
|
||||
(if (symbolp place)
|
||||
(list 'setq place val)
|
||||
(let ((mutator (assoc (car place) *setf-place-list*)))
|
||||
(if (null mutator)
|
||||
(error '|setf: unknown place | (car place))
|
||||
(if (eq (caddr mutator) 'identity)
|
||||
(cons (cadr mutator) (append (cdr place) (list val)))
|
||||
(list (cadr mutator)
|
||||
(cons (caddr mutator) (cdr place))
|
||||
val))))))
|
||||
|
||||
(defmacro setf args
|
||||
(f-body
|
||||
((label setf-
|
||||
(lambda (args)
|
||||
(if (null args)
|
||||
nil
|
||||
(cons (setf-place-mutator (car args) (cadr args))
|
||||
(setf- (cddr args))))))
|
||||
args)))
|
||||
|
||||
(defun revappend (l1 l2) (nconc (reverse l1) l2))
|
||||
(defun nreconc (l1 l2) (nconc (nreverse l1) l2))
|
||||
|
||||
(defun list-to-vector (l) (apply vector l))
|
||||
(defun vector-to-list (v)
|
||||
(let ((i (- (length v) 1))
|
||||
(l nil))
|
||||
(while (>= i 0)
|
||||
(setq l (cons (aref v i) l))
|
||||
(setq i (- i 1)))
|
||||
l))
|
||||
|
||||
(defun self-evaluating-p (x)
|
||||
(or (eq x nil)
|
||||
(eq x T)
|
||||
(and (atom x)
|
||||
(not (symbolp x)))))
|
||||
|
||||
(defun functionp (x)
|
||||
(or (builtinp x)
|
||||
(and (consp x) (eq (car x) 'lambda))))
|
||||
|
||||
; backquote
|
||||
(defmacro backquote (x) (bq-process x))
|
||||
|
||||
(defun splice-form-p (x)
|
||||
(or (and (consp x) (or (eq (car x) '*comma-at*)
|
||||
(eq (car x) '*comma-dot*)))
|
||||
(eq x '*comma*)))
|
||||
|
||||
(defun bq-process (x)
|
||||
(cond ((self-evaluating-p x)
|
||||
(if (vectorp x)
|
||||
(let ((body (bq-process (vector-to-list x))))
|
||||
(if (eq (car body) 'list)
|
||||
(cons vector (cdr body))
|
||||
(list apply vector body)))
|
||||
x))
|
||||
((atom x) (list 'quote x))
|
||||
((eq (car x) 'backquote) (bq-process (bq-process (cadr x))))
|
||||
((eq (car x) '*comma*) (cadr x))
|
||||
((not (any splice-form-p x))
|
||||
(let ((lc (lastcdr x))
|
||||
(forms (map bq-bracket1 x)))
|
||||
(if (null lc)
|
||||
(cons 'list forms)
|
||||
(nconc (cons 'nlist* forms) (list (bq-process lc))))))
|
||||
(T (let ((p x) (q ()))
|
||||
(while (and (consp p)
|
||||
(not (eq (car p) '*comma*)))
|
||||
(setq q (cons (bq-bracket (car p)) q))
|
||||
(setq p (cdr p)))
|
||||
(let ((forms
|
||||
(cond ((consp p) (nreconc q (list (cadr p))))
|
||||
((null p) (nreverse q))
|
||||
(T (nreconc q (list (bq-process p)))))))
|
||||
(if (null (cdr forms))
|
||||
(car forms)
|
||||
(cons 'nconc forms)))))))
|
||||
|
||||
(defun bq-bracket (x)
|
||||
(cond ((atom x) (list cons (bq-process x) nil))
|
||||
((eq (car x) '*comma*) (list cons (cadr x) nil))
|
||||
((eq (car x) '*comma-at*) (list 'copy-list (cadr x)))
|
||||
((eq (car x) '*comma-dot*) (cadr x))
|
||||
(T (list cons (bq-process x) nil))))
|
||||
|
||||
; bracket without splicing
|
||||
(defun bq-bracket1 (x)
|
||||
(if (and (consp x) (eq (car x) '*comma*))
|
||||
(cadr x)
|
||||
(bq-process x)))
|
||||
|
||||
(defmacro assert (expr) `(if ,expr T (raise '(assert-failed ,expr))))
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
typedef struct {
|
||||
size_t n, maxsize;
|
||||
unsigned long *items;
|
||||
} ltable_t;
|
||||
|
||||
void ltable_init(ltable_t *t, size_t n)
|
||||
{
|
||||
t->n = 0;
|
||||
t->maxsize = n;
|
||||
t->items = (unsigned long*)malloc(n * sizeof(unsigned long));
|
||||
}
|
||||
|
||||
void ltable_clear(ltable_t *t)
|
||||
{
|
||||
t->n = 0;
|
||||
}
|
||||
|
||||
void ltable_insert(ltable_t *t, unsigned long item)
|
||||
{
|
||||
unsigned long *p;
|
||||
|
||||
if (t->n == t->maxsize) {
|
||||