diff --git a/build/lisp.tcl b/build/lisp.tcl index aafbf9be..8cc6807f 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -583,6 +583,13 @@ respond "_" "share;eigen fasl_share;eigen trlisp\r" respond "_" "\032" type ":kill\r" +### build share;array fasl for macsyma + +respond "*" ":maxtul;mcl\r" +respond "_" "share;_maxsrc;array\r" +respond "_" "\032" +type ":kill\r" + ### more lisplib stuff respond "*" "complr\013" respond "_" "liblsp;_libdoc;%print\r" diff --git a/src/maxsrc/array.5 b/src/maxsrc/array.5 new file mode 100644 index 00000000..687c51c0 --- /dev/null +++ b/src/maxsrc/array.5 @@ -0,0 +1,57 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module array) + +;;; Macsyma User array utilities originally due to CFFK. + +(defmfun $listarray (ary) + (Cons '(mlist) + (cond ((mget ary 'hashar) + (mapcar #'(lambda (subs) ($arrayapply ary subs)) + (cdddr (meval (list '($arrayinfo) ary))))) + ((mget ary 'array) (listarray (mget ary 'array))) + (t + (merror "Argument to LISTARRAY must be an array:~%~M" ary))))) + +(defmfun $fillarray (ary1 ary2) + (let ((ary + (or + (mget ary1 'array) + (merror "First argument to FILLARRAY must be a declared array:~%~M" ary1)))) + (fillarray + ary + (cond (($listp ary2) (cdr ary2)) + ((mget ary2 'array)) + (t + (merror + "Second argument to FILLARRAY must be an array or list:~%~M" ary2)))) + ary1)) + +(defmspec $rearray (l) (setq l (cdr l)) + (cond ((> (length l) 6) + (merror "Too many arguments to REARRAY:~%~M" l)) + ((< (length l) 2) + (merror "Too few arguments to REARRAY:~%~M" l))) + (let ((name (car l)) + (ary (cond ((mget (car l) 'array)) + (t + (merror "First argument to REARRAY must be a declared array:~%~M" + (car l)))))) + (setq l (cdr l) + l (mapcar #'(lambda (x) + (setq x (meval x)) + (cond ((not (eq (typep x) 'fixnum)) + (merror + "Non-integer dimension to REARRAY:~%~M" + x))) + (1+ x)) + l)) + (let ((new-array + (apply '*rearray (cons ary + (cons (car (arraydims ary)) l))))) + #+Franz(mputprop name new-array 'array) + ) + name)) +