mirror of
https://github.com/PDP-10/its.git
synced 2026-01-19 01:27:05 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
166 lines
5.3 KiB
Common Lisp
166 lines
5.3 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module ar)
|
||
|
||
(DECLARE (SPECIAL EVARRP MUNBOUND FLOUNBOUND FIXUNBOUND))
|
||
|
||
;;; This code needs to be checked carefully for the 3600.
|
||
(defstruct (mgenarray conc-name array)
|
||
aref
|
||
aset
|
||
type
|
||
NULL
|
||
GENERATOR
|
||
CONTENT)
|
||
|
||
(DEFUN MARRAY-TYPE (X)
|
||
(OR (CDR (ASSQ (ARRAY-TYPE X)
|
||
'((FLONUM . $FLOAT)
|
||
(FIXNUM . $FIXNUM))))
|
||
(MGENARRAY-TYPE X)))
|
||
|
||
(DEFMFUN $MAKE_ARRAY (TYPE &REST DIML)
|
||
(LET ((LTYPE (ASSQ TYPE '(($FLOAT . FLONUM) ($FLONUM . FLONUM)
|
||
($FIXNUM . FIXNUM)))))
|
||
(COND ((NOT LTYPE)
|
||
(COND ((EQ TYPE '$ANY)
|
||
(MAKE-MGENARRAY TYPE '$ANY
|
||
CONTENT (LEXPR-FUNCALL '*ARRAY NIL T DIML)))
|
||
((EQ TYPE '$HASHED)
|
||
(LET ((KLUDGE (GENSYM)))
|
||
(OR (FIXP (CAR DIML))
|
||
(MERROR "non-integer number of dimensions: ~M"
|
||
(CAR DIML)))
|
||
(INSURE-ARRAY-PROPS KLUDGE () (CAR DIML))
|
||
(MAKE-MGENARRAY TYPE '$HASHED
|
||
CONTENT KLUDGE)))
|
||
((EQ TYPE '$FUNCTIONAL)
|
||
;; MAKE_ARRAY('FUNCTIONAL,LAMBDA(...),'ARRAY_TYPE,...)
|
||
(OR (> (LENGTH DIML) 1)
|
||
(MERROR "not enough arguments for functional array specification"))
|
||
(LET ((AR (APPLY #'$MAKE_ARRAY (CDR DIML)))
|
||
(THE-NULL))
|
||
(CASEQ (MARRAY-TYPE AR)
|
||
(($FIXNUM)
|
||
(FILLARRAY AR (LIST (SETQ THE-NULL FIXUNBOUND))))
|
||
(($FLOAT)
|
||
(FILLARRAY AR (LIST (SETQ THE-NULL FLOUNBOUND))))
|
||
(($ANY)
|
||
(FILLARRAY (MGENARRAY-CONTENT AR) (LIST (SETQ THE-NULL MUNBOUND))))
|
||
(T
|
||
;; Nothing to do for hashed arrays. Is FUNCTIONAL here
|
||
;; an error?
|
||
(SETQ THE-NULL 'NOTEXIST)))
|
||
(MAKE-MGENARRAY TYPE '$FUNCTIONAL
|
||
CONTENT AR
|
||
GENERATOR (CAR DIML)
|
||
NULL THE-NULL)))
|
||
('ELSE
|
||
(MERROR "Array type of ~M is not recognized by MAKE_ARRAY" TYPE))))
|
||
('ELSE
|
||
(LEXPR-FUNCALL '*ARRAY NIL (CDR LTYPE) DIML)))))
|
||
|
||
(DEFMFUN DIMENSION-ARRAY-OBJECT (FORM RESULT &AUX (MTYPE (MARRAY-TYPE FORM)))
|
||
(DIMENSION-STRING
|
||
(NCONC (EXPLODEN "{Array: ")
|
||
(CDR (EXPLODEN MTYPE))
|
||
(EXPLODEN " ")
|
||
(EXPLODEN (MAKNUM FORM))
|
||
(IF (MEMQ MTYPE '($FLOAT $FIXNUM $ANY))
|
||
(NCONC (EXPLODEN "[")
|
||
(DO ((L (CDR (ARRAYDIMS (IF (MEMQ MTYPE '($FLOAT $FIXNUM))
|
||
FORM
|
||
(MGENARRAY-CONTENT FORM))))
|
||
(CDR L))
|
||
(V NIL
|
||
(NCONC (NREVERSE (EXPLODEN (CAR L))) V)))
|
||
((NULL L) (NREVERSE V))
|
||
(IF V (PUSH #/, V)))
|
||
(EXPLODEN "]")))
|
||
(EXPLODEN "}"))
|
||
RESULT))
|
||
|
||
(DEFUN MARRAY-CHECK (A)
|
||
(IF (EQ (TYPEP A) 'ARRAY)
|
||
(CASEQ (MARRAY-TYPE A)
|
||
(($FIXNUM $FLOAT) A)
|
||
(($ANY) (MGENARRAY-CONTENT A))
|
||
(($HASHED $FUNCTIONAL)
|
||
;; BUG: It does have a number of dimensions! Gosh. -GJC
|
||
(MERROR "Hashed array has no dimension info: ~M" A))
|
||
(T
|
||
(MARRAY-TYPE-UNKNOWN A)))
|
||
(MERROR "Not an array: ~M" A)))
|
||
|
||
(DEFMFUN $ARRAY_NUMBER_OF_DIMENSIONS (A)
|
||
(ARRAY-/#-DIMS (MARRAY-CHECK A)))
|
||
|
||
(DEFMFUN $ARRAY_DIMENSION_N (N A)
|
||
(ARRAY-DIMENSION-N N (MARRAY-CHECK A)))
|
||
|
||
(DEFUN MARRAY-TYPE-UNKNOWN (X)
|
||
(MERROR "BUG: Array of unhandled type: ~S" X))
|
||
|
||
(DEFUN MARRAYREF-GENSUB (ARRAY IND1 INDS)
|
||
(CASEQ (MARRAY-TYPE ARRAY)
|
||
;; We are using a CASEQ on the TYPE instead of a FUNCALL, (or SUBRCALL)
|
||
;; because we are losers. All this stuff uses too many functions from
|
||
;; the "MLISP" modual, which are not really suitable for the kind of
|
||
;; speed and simplicity we want anyway. Ah me. Also, passing the single
|
||
;; unconsed index IND1 around is a dubious optimization, which causes
|
||
;; extra consing in the case of hashed arrays.
|
||
(($HASHED)
|
||
(LEXPR-FUNCALL #'MARRAYREF (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(($FLOAT $FIXNUM)
|
||
(LEXPR-FUNCALL ARRAY IND1 INDS))
|
||
(($ANY)
|
||
(LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(($FUNCTIONAL)
|
||
(LET ((VALUE (LET ((EVARRP T))
|
||
;; special variable changes behavior of hashed-array
|
||
;; referencing functions in case of not finding an element.
|
||
(*CATCH 'EVARRP (MARRAYREF-GENSUB
|
||
(MGENARRAY-CONTENT ARRAY) IND1 INDS)))))
|
||
(IF (EQUAL VALUE (MGENARRAY-NULL ARRAY))
|
||
(MARRAYSET-GENSUB (LEXPR-FUNCALL #'MFUNCALL
|
||
(MGENARRAY-GENERATOR ARRAY)
|
||
;; the first argument we pass the
|
||
;; function is a SELF variable.
|
||
ARRAY
|
||
;; extra consing here! LEXPR madness.
|
||
IND1
|
||
INDS)
|
||
(MGENARRAY-CONTENT ARRAY) IND1 INDS)
|
||
VALUE)))
|
||
(T
|
||
(MARRAY-TYPE-UNKNOWN ARRAY))))
|
||
|
||
|
||
(DEFUN MARRAYSET-GENSUB (VAL ARRAY IND1 INDS)
|
||
(CASEQ (MARRAY-TYPE ARRAY)
|
||
(($HASHED)
|
||
(LEXPR-FUNCALL #'MARRAYSET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(($ANY)
|
||
#-3600(STORE (LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS) VAL)
|
||
#+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(($FLOAT $FIXNUM)
|
||
#-3600(STORE (LEXPR-FUNCALL ARRAY IND1 INDS) VAL)
|
||
#+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(($FUNCTIONAL)
|
||
(MARRAYSET-GENSUB VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS))
|
||
(T
|
||
(MARRAY-TYPE-UNKNOWN ARRAY))))
|
||
|
||
|
||
;; Extensions to MEVAL.
|
||
|
||
(DEFMFUN MEVAL1-EXTEND (FORM)
|
||
(LET ((L (MEVALARGS (CDR FORM))))
|
||
(MARRAYREF-GENSUB (CAAR FORM) (CAR L) (CDR L))))
|
||
|
||
(DEFMFUN ARRSTORE-EXTEND (A L R)
|
||
(MARRAYSET-GENSUB R A (CAR L) (CDR L)))
|
||
|