ref: 7412a31af34f601049f52da6f63b466d74bd6f0d
parent: af8b332367752471d1321a096a9604ef467892a2
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Sep 3 11:42:00 EDT 2008
removing more clutter
--- a/femtolisp/ast/asttools.scm
+++ /dev/null
@@ -1,88 +1,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))
--- a/femtolisp/ast/out.lsp
+++ /dev/null
@@ -1,1 +1,0 @@
-'(r-expressions (r-call library MASS) (r-call dyn.load "starp.so") (<- ppcommand (lambda (...) (let nil (r-block (r-call .Call "ppcommand" (r-call list r-dotdotdot)))))) (<- ppvcommand (lambda (va) (let nil (r-block (r-call .Call "ppcommand" va))))) (<- ppinvoke ppcommand) (<- pploadconfig (lambda (fileName) (let nil (r-block (r-call .Call "pploadconfig" fileName))))) (<- ppconnect (lambda (numProcs machines) (let ((machines nil) (numProcs nil)) (r-block (when (missing numProcs) (<- numProcs nil)) (when (missing machines) (<- machines nil)) (r-call .Call "ppconnect" (r-call list numProcs machines)))))) (<- ppgetlogpath (lambda nil (let nil (r-block (r-call .Call "ppgetlogpath"))))) (<- ppgetlog (lambda nil (let nil (r-block (r-call .Call "ppgetlog"))))) (<- ppshowdashboard (lambda nil (let nil (r-block (r-call .Call "ppshowdashboard"))))) (<- pphidedashboard (lambda nil (let nil (r-block (r-call .Call "pphidedashboard"))))) (<- revealargs (lambda (dots) (let nil (r-block (r-call .Call "_revealArgs" dots))))) (<- listargs (lambda (...) (let nil (r-block (r-call revealargs (r-call get "...")))))) (<- ppping (lambda nil (let nil (r-block (r-call ppcommand "ppping"))))) (<- ppver (lambda nil (let nil (r-block (r-call ppcommand "pp_ver"))))) (<- STARPDIST "../../../linkdist") (<- STARPPLATFORM "ia32_linux") (r-call .Call "_setstarpdist" STARPDIST) (r-call .Call "_setstarpplat" STARPPLATFORM) (r-call pploadconfig (r-call paste STARPDIST "/config/starpd.properties" (*named* sep ""))) (<- dimdis (lambda (v) (let nil (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 (lambda (x) (let nil (r-block (&& (|\|\|| (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-block (ref= #:g0 (r-call c "dlayout" "numeric")) (<- p (r-call class p #:g0)) #:g0) (<- darray (lambda (id shape distribution isreal) (let ((d nil) (distribution nil) (shape nil)) (r-block (<- shape (r-call as.array shape)) (<- distribution (r-call + distribution 1)) (r-block (ref= #:g1 (r-call append "dlayoutn" (r-call toString distribution) (r-call class shape))) (<- shape (r-call class shape #:g1)) #:g1) (<- d (r-call list (*named* id id) (*named* shape shape) (*named* isreal isreal) (*named* logical *r-false*) nil nil)) (r-block (<- d (r-call class d "darray")) "darray") d)))) (<- darraydist (lambda (da) (let nil (r-block (r-call as.numeric (r-call r-aref (r-call class (r-call r-aref da (index-in-strlist shape (r-call attr da "names")))) 2)))))) (<- is.darray (lambda (x) (let nil (r-block (r-call == (r-call r-index (r-call class x) 1) "darray"))))) (<- is.nd (lambda (x) (let nil (r-block (r-call != (r-call length (r-call dim x)) 2))))) (<- is.darraynd (lambda (x) (let nil (r-block (&& (r-call is.darray x) (r-call is.nd x)))))) (<- is.dlayout (lambda (x) (let nil (r-block (r-call any (r-call == (r-call class x) "dlayout")))))) (<- vdim (lambda (x) (let nil (r-block (if (r-call is.vector x) (r-call length x) (r-call dim x)))))) (<- |[[.dlayoutn| (<- |[.dlayoutn| (lambda (dl n) (let ((didi nil) (r nil) (dd nil)) (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-block (ref= #:g2 (r-call append "dlayoutn" (r-call toString didi) (r-call class r))) (<- r (r-call class r #:g2)) #:g2) (return r)))))))) (<- print.darray (lambda (d ...) (let ((shs nil) (sh nil)) (r-block (<- sh (r-call as
\ No newline at end of file
--- a/femtolisp/ast/plambda-js.scm
+++ /dev/null
@@ -1,23 +1,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)))))
--- a/femtolisp/ast/rpasses.lsp
+++ b/femtolisp/ast/rpasses.lsp
@@ -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))
--- a/femtolisp/ast/rpasses.scm
+++ /dev/null
@@ -1,206 +1,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*))
-; (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)
--- a/femtolisp/ast/starpR.lsp
+++ /dev/null
@@ -1,120 +1,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*) ())))
--- a/llt/u8.txt
+++ /dev/null
@@ -1,19 +1,0 @@
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов
-% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка количества исходящих аргументов% Проверка к
-