removing more clutter
This commit is contained in:
JeffBezanson
parent
af8b332367
commit
7412a31af3
|
|
@ -1,88 +0,0 @@
|
|||
; 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))
|
||||
File diff suppressed because one or more lines are too long
|
|
@ -1,23 +0,0 @@
|
|||
; 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)))))
|
||||
|
|
@ -110,7 +110,7 @@
|
|||
;)
|
||||
(define (main)
|
||||
(progn
|
||||
(define *input* (load "starpR.lsp"))
|
||||
(define *input* (load "???.lsp"))
|
||||
;(define t0 ((java.util.Date:new):getTime))
|
||||
(time (compile-ish *input*))
|
||||
;(define t1 ((java.util.Date:new):getTime))
|
||||
|
|
|
|||
|
|
@ -1,206 +0,0 @@
|
|||
(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)
|
||||
|
|
@ -1,120 +0,0 @@
|
|||
'(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*) ())))
|
||||
19
llt/u8.txt
19
llt/u8.txt
|
|
@ -1,19 +0,0 @@
|
|||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
|
||||
% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка к
|
||||
|
||||
Loading…
Reference in New Issue