mirror of
https://github.com/PDP-10/its.git
synced 2026-02-03 15:22:48 +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.
579 lines
18 KiB
Common Lisp
579 lines
18 KiB
Common Lisp
;;; -*- Mode: Lisp; Package: Macsyma -*-
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; 1001 TRANSLATE properties for everyone. ;;;
|
||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||
;;; Maintained by GJC ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
;;; This file handles System FSUBR translation properties that
|
||
;;; were not handled in TRANSL.
|
||
|
||
(macsyma-module trans1)
|
||
|
||
|
||
(TRANSL-MODULE TRANS1)
|
||
|
||
;; Also defined in TRANSL;TRANSS
|
||
#-LISPM (DEFVAR $TR_WINDY T)
|
||
|
||
|
||
;;;;;;;; THE FOLLOWING ARE MOSTLY FROM JPG MLISP ;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
;;; MMAPEV DOES error checking and a macar of MEVAL down the arguments.
|
||
;;; The second arg to MMAPEV is purely for printing of error messages
|
||
;;; except for SCANMAP, which is obscure.
|
||
|
||
(comment
|
||
|
||
(DEFMFUN MMAPEV (MAPFUN L)
|
||
(IF (< (LENGTH L) 2)
|
||
(MERROR "~:M called with fewer than 2 args" MAPFUN))
|
||
(LET ((U (GETOPR (MEVAL (CAR L)))))
|
||
(AUTOLDCHK U)
|
||
(BADFUNCHK (CAR L) U NIL)
|
||
(IF (ATOM U)
|
||
;; number of argument checking before mapping,
|
||
;; some efficiency gain, really, how minor.
|
||
;; he should instead do some trampolining and
|
||
;; get some real efficiency gains.
|
||
(MARGCHK U (COND ((EQ MAPFUN '$SCANMAP)
|
||
(NCONS (CADR L)))
|
||
(T (CDR L)))))
|
||
(CONS U (MAPCAR 'MEVAL (CDR L)))))
|
||
)
|
||
|
||
(comment
|
||
(DEFMFUN $APPLY FEXPR (L)
|
||
(TWO-ARG-CHECK L)
|
||
((LAMBDA (FUN ARG)
|
||
(COND ((NOT ($LISTP ARG))
|
||
(DISPLA FUN) (DISPLA ARG) (MERROR "Second arg to APPLY must be a list")))
|
||
(AUTOLDCHK (SETQ FUN (GETOPR FUN)))
|
||
(COND ((EQ (GET FUN 'DIMENSION) 'DIMENSION-INFIX) (TWOARGCHK ARG FUN)))
|
||
(MAPPLY FUN (CDR ARG) (CAR L)))
|
||
(MEVAL (CAR L)) (MEVAL (CADR L))))
|
||
)
|
||
|
||
;;; APPLY(F,[X]) is an idiom for funcall.
|
||
|
||
(DEFUN QUOTED-SYMBOLP (FORM)
|
||
(AND (EQ (TYPEP FORM) 'LIST)
|
||
(EQ 'QUOTE (CAR FORM))
|
||
(SYMBOLP (CADR FORM))))
|
||
|
||
(DEF%TR $APPLY (FORM)
|
||
(LET* ((FUN (DTRANSLATE (CADR FORM)))
|
||
(MODE (COND ((ATOM FUN)
|
||
(FUNCTION-MODE-@ FUN))
|
||
((QUOTED-SYMBOLP FUN)
|
||
(FUNCTION-MODE (CADR FUN)))
|
||
('ELSE
|
||
'$ANY))))
|
||
(COND (($LISTP (CADDR FORM))
|
||
(LET ((ARGS (TR-ARGS (CDR (CADDR FORM)))))
|
||
(CALL-AND-SIMP MODE
|
||
'MFUNCALL
|
||
`(,FUN ,@ARGS))))
|
||
(T
|
||
(LET ((ARG (DTRANSLATE (CADDR FORM))))
|
||
(CALL-AND-SIMP MODE 'MAPPLY-TR
|
||
`(,FUN ,ARG)))))))
|
||
|
||
;;; (DEFMFUN $MAP FEXPR (L) (APPLY 'MAP1 (MMAPEV 'MAP L)))
|
||
|
||
(DEF%TR $MAP (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY 'MAP1 `((GETOPR ,FUN) . ,ARGS))))
|
||
|
||
;;; (DEFMFUN $MAPLIST FEXPR (L)
|
||
;;; ((LAMBDA (MAPLP RES)
|
||
;;; (SETQ RES (APPLY 'MAP1 (MMAPEV 'MAPLIST L)))
|
||
;;; (COND ((ATOM RES) (LIST '(MLIST) RES))
|
||
;;; ((EQ (CAAR RES) 'MLIST) RES)
|
||
;;; (T (CONS '(MLIST) (CDR RES)))))
|
||
;;; T NIL))
|
||
|
||
(DEF%TR $MAPLIST (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
;; this statement saves the trouble of adding autoload definitions
|
||
;; for runtime translator support.
|
||
(PUSH-AUTOLOAD-DEF 'MARRAYREF '(MAPLIST_TR))
|
||
`($ANY . (MAPLIST_TR ,FUN ,@ARGS))))
|
||
|
||
;;; (DEFMFUN $FULLMAP FEXPR (L)
|
||
;;; (SETQ L (MMAPEV 'FULLMAP L)) (FMAP1 (CAR L) (CDR L) NIL))
|
||
|
||
(DEF%TR $FULLMAP (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY 'FMAP1 `((GETOPR ,FUN) (LIST . ,ARGS) NIL))))
|
||
|
||
;;; (DEFMFUN $MATRIXMAP FEXPR (L)
|
||
;;; ((LAMBDA (FMAPLVL) (APPLY 'FMAPL1 (MMAPEV 'MATRIXMAP L))) 2))
|
||
|
||
(DEF%TR $MATRIXMAP (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY `(LAMBDA (FMAPLVL)
|
||
(FMAPL1 (GETOPR ,FUN) . ,ARGS))
|
||
'(2))))
|
||
|
||
;;; (DEFMFUN $FULLMAPL FEXPR (L) (APPLY 'FMAPL1 (MMAPEV 'FULLMAPL L)))
|
||
|
||
(DEF%TR $FULLMAPL (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY 'FMAPL1 `((GETOPR ,FUN) . ,ARGS))))
|
||
|
||
;;;(DEFMFUN $OUTERMAP FEXPR (L)
|
||
;;; (APPLY (COND ((= (LENGTH L) 2) 'FMAPL1) (T 'OUTERMAP1)) (MMAPEV 'OUTERMAP L)))
|
||
|
||
(DEF%TR $OUTERMAP (FORM)
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY (COND ((= (LENGTH ARGS) 1) 'FMAPL1)
|
||
(T 'OUTERMAP1))
|
||
`((GETOPR ,FUN) ,@ARGS))))
|
||
|
||
|
||
;;;(DEFMFUN $SCANMAP FEXPR (L)
|
||
;;; (LET ((SCANMAPP T)) (SSIMPLIFYA (APPLY 'SCANMAP1 (MMAPEV '$SCANMAP L)))))
|
||
|
||
(DEF%TR $SCANMAP (FORM)
|
||
(PUSH-AUTOLOAD-DEF '$SCANMAP '(SCANMAP1))
|
||
;; there's something more fundamental about the above than
|
||
;; just autoload definitions.
|
||
(LET (((FUN . ARGS) (TR-ARGS (CDR FORM))))
|
||
(CALL-AND-SIMP '$ANY 'SCANMAP1 `((GETOPR ,FUN) ,@ARGS))))
|
||
|
||
;;;(DEFMFUN $QPUT FEXPR (L)
|
||
;;; (COND ((NOT (= (LENGTH L) 3)) (ERLIST '|Wrong number of args to QPUT|)))
|
||
;;; ($PUT (CAR L) (CADR L) (CADDR L)))
|
||
|
||
(DEF%TR $QPUT (FORM)
|
||
`($ANY $PUT ',(CADR FORM) ',(CADDR FORM) ',(CADDDR FORM)))
|
||
|
||
;;;(DEFMFUN $SUBVAR FEXPR (L)
|
||
;;; (COND ((NULL L) (ERLIST "Wrong number of args to SUBVAR")))
|
||
;;; (MEVAL (CONS '(MQAPPLY ARRAY) L)))
|
||
|
||
(DEF%TR $SUBVAR (FORM)
|
||
(TRANSLATE (CONS '(MQAPPLY ARRAY) (CDR FORM))))
|
||
|
||
;;; From JPG;COMM >
|
||
;;;(DEFMFUN $PART N (PART1 (LISTIFY N) NIL NIL $INFLAG))
|
||
;;;
|
||
;;;(DEFMFUN $INPART N (PART1 (LISTIFY N) NIL NIL T))
|
||
;;;
|
||
;;;(DEFMFUN $SUBSTPART FEXPR (L) (PART1 L T NIL $INFLAG))
|
||
;;;
|
||
;;;(DEFMFUN $SUBSTINPART FEXPR (L) (PART1 L T NIL T))
|
||
;;;
|
||
;;;(DEFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ....)
|
||
|
||
;;; If the evaluation of the first argument does not depend on the
|
||
;;; setting of the special variable PIECE, then it need not be
|
||
;;; evaluated inside of PART1. If the PIECE feature is used, then
|
||
;;; we must send down an expression to PART1 which when evaluated has
|
||
;;; the proper environment for the compiled-away variable names in the
|
||
;;; environment of the calling function.
|
||
;;; It is possible to get unbelivebly strange results from the order of
|
||
;;; evaluation of the arguments to $SUBSTPART, these crocks shall not
|
||
;;; be supported.
|
||
;;; The PIECE feature is not as often used as say,
|
||
;;; SUBSTPART("*",EXP,0) is.
|
||
|
||
(DEF%TR $SUBSTPART (FORM)
|
||
(SUBSTPART-TRANSLATION FORM T NIL '$INFLAG))
|
||
|
||
(DEF%TR $SUBSTINPART (FORM)
|
||
(SUBSTPART-TRANSLATION FORM T NIL T))
|
||
|
||
(DEFUN FOR-EVAL-THEN-MQUOTE-SIMP-ARGL (L)
|
||
; (MAPCAR #'(LAMBDA (U) ;;; consing not important here.
|
||
; `(LIST '(MQUOTE SIMP) ,U))
|
||
; L)
|
||
; JONL broke the fucking compiler. So I re-write this as=>
|
||
(PROG (V)
|
||
LOOP
|
||
(IF (NULL L) (RETURN (NREVERSE V)))
|
||
(PUSH `(LIST '(MQUOTE SIMP) ,(POP L)) V)
|
||
(GO LOOP)))
|
||
|
||
(DEFUN SUBSTPART-TRANSLATION (FORM FLAG1 FLAG2 FLAG3)
|
||
(LET* ((SUBST-ITEM (DTRANSLATE (CADR FORM)))
|
||
(FREEVARS (FREE-LISP-VARS SUBST-ITEM))
|
||
(ARGL (TR-ARGS (CDDR FORM))))
|
||
(COND ((NULL (ASSQ '$PIECE FREEVARS))
|
||
; this code is just to screw the people who
|
||
; would use $PIECE non lexicaly. Not really, the
|
||
; closure hacking is a lot slower at run time than
|
||
; this easy case, so no sense screwing the people who
|
||
; don't use $PIECE in foolish ways.
|
||
`($ANY . (SIMPLIFY
|
||
(PART1
|
||
(LIST ,@(FOR-EVAL-THEN-MQUOTE-SIMP-ARGL
|
||
(CONS SUBST-ITEM ARGL)))
|
||
|
||
,FLAG1 ,FLAG2 ,FLAG3))))
|
||
(T
|
||
(SETQ FREEVARS (TBOUND-FREE-VARS FREEVARS))
|
||
(SIDE-EFFECT-FREE-CHECK (CADR FREEVARS) (CADR FORM))
|
||
`($ANY . (SIMPLIFY
|
||
(PART1 (LIST (FUNGEN&ENV-FOR-MEVAL
|
||
,(DELETE '$PIECE (CAR FREEVARS))
|
||
($PIECE) ,SUBST-ITEM)
|
||
,@(FOR-EVAL-THEN-MQUOTE-SIMP-ARGL ARGL))
|
||
,FLAG1 ,FLAG2 ,FLAG3)))))))
|
||
|
||
|
||
|
||
|
||
;;; From JPG;SUPRV >
|
||
(comment
|
||
(DEFMFUN $ERRCATCH FEXPR (X)
|
||
((LAMBDA (ERRCATCH RET)
|
||
(COND ((NULL (SETQ RET
|
||
(ERRSET (APPLY 'MPROGN X)
|
||
LISPERRPRINT)))
|
||
(ERRLFUN1 ERRCATCH)))
|
||
(CONS '(MLIST) RET))
|
||
(CONS BINDLIST LOCLIST) NIL)))
|
||
|
||
;;; This is could be done better on the LISPM
|
||
|
||
(DEF%TR $ERRCATCH (FORM)
|
||
(SETQ FORM (TRANSLATE `((MPROGN) ,@(CDR FORM))))
|
||
`(,(CAR FORM) . ((LAMBDA (ERRCATCH RET) ;;; ERRCATCH SPECIAL IN TINCLU >
|
||
(COND ((NULL (SETQ RET
|
||
(ERRSET ,(CDR FORM)
|
||
LISPERRPRINT)))
|
||
(ERRLFUN1 ERRCATCH)))
|
||
(CONS '(MLIST) RET))
|
||
(CONS BINDLIST LOCLIST) NIL)))
|
||
|
||
|
||
(COMMENT
|
||
(DEFMFUN $CATCH FEXPR (X)
|
||
((LAMBDA (MCATCH)
|
||
(PROG2 NIL (*CATCH 'MCATCH (APPLY 'MPROGN X))
|
||
(ERRLFUN1 MCATCH)))
|
||
(CONS BINDLIST LOCLIST))))
|
||
|
||
;;; The MODE of a CATCH could either be the MODE of the last of the PROGN
|
||
;;; or the mode of the THROW. The THROW may be hard to find, so this goes
|
||
;;; on the assumption that the mode of the PROGN is enough to tell.
|
||
|
||
(DEF%TR $CATCH (FORM)
|
||
(LET (((MODE . BODY) (TRANSLATE `((MPROGN) . ,(CDR FORM)))))
|
||
`(,MODE . ((LAMBDA ()
|
||
((LAMBDA (MCATCH)
|
||
(PROG2 NIL
|
||
(*CATCH
|
||
'MCATCH ,BODY)
|
||
(ERRLFUN1 MCATCH)))
|
||
(CONS BINDLIST LOCLIST)))))))
|
||
(COMMENT
|
||
(DEFMFUN $THROW (X)
|
||
(COND ((NULL MCATCH) (DISPLA X) (ERLIST '|THROW not within CATCH|)))
|
||
(*THROW 'MCATCH X)))
|
||
|
||
(DEF%TR $THROW (FORM)
|
||
(LET (((MODE . EXP) (TRANSLATE (CADR FORM))))
|
||
`(,MODE . ((LAMBDA (X)
|
||
(COND ((NULL MCATCH)
|
||
(DISPLA X)
|
||
(*MERROR '|THROW not within CATCH|)))
|
||
(*THROW 'MCATCH X))
|
||
,EXP))))
|
||
|
||
;;; From RZ;ASUM >. He should know better.
|
||
(comment
|
||
(DEFMFUN $sum fexpr (l)
|
||
(cond ((not (= (length l) 4))
|
||
(erlist '|Wrong no. of args to SUM|))
|
||
((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
|
||
))))
|
||
|
||
;;; From RZ;COMBIN >
|
||
(comment
|
||
(DEFMFUN $product fexpr (l)
|
||
(cond ((not (= (length l) 4)) (erlist '|Wrong no. of args to product|))
|
||
((dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) nil)))))
|
||
;;; "dosum" will call MEVAL and act like a special form if it can.
|
||
;;; MEVAL will work on LISP expression, so we can translate those args.
|
||
|
||
(DEFUN START-VAL (SUMP MODE)
|
||
(CASEQ MODE
|
||
(($FLOAT)
|
||
(IF SUMP 0.0 1.0))
|
||
(T
|
||
(IF SUMP 0 1))))
|
||
|
||
(DEF%TR $SUM (FORM)
|
||
(LET (((/0 N) (MAPCAR #'TRANSLATE (CDDDR FORM)))
|
||
(FLAG (EQ (CAAR FORM) '$SUM))
|
||
(VAR (CADDR FORM))
|
||
(SUM (GENSYM)))
|
||
(COND ((AND (EQ (CAR /0) '$FIXNUM)
|
||
(EQ (CAR N) '$FIXNUM))
|
||
(LET ((SUM-EXP
|
||
(TR-LOCAL-EXP `((,(COND (FLAG 'MPLUS)
|
||
(T 'MTIMES)))
|
||
,SUM ,(CADR FORM))
|
||
SUM '$FIXNUM
|
||
VAR '$FIXNUM)))
|
||
;; here is the bummer. We need to know the
|
||
;; mode of SUM before we know the mode of the
|
||
;; SUM-EXP, but that tells us something about
|
||
;; the mode of the SUM.
|
||
;; When the mode is float we really need to know
|
||
;; because of the initialization of the SUM, which
|
||
;; must be correct if COMPLR is to win on things
|
||
;; like (*$ (DO ...) ...)
|
||
(IF (EQ (CAR SUM-EXP) '$FLOAT)
|
||
(SETQ SUM-EXP
|
||
(TR-LOCAL-EXP
|
||
`((,(COND (FLAG 'MPLUS)
|
||
(T 'MTIMES)))
|
||
,SUM ,(CADR FORM))
|
||
SUM '$FLOAT
|
||
VAR '$FIXNUM)))
|
||
;; hey if this changes Modes on us, forget it man,
|
||
;; geezz. lets not bother checking, and just
|
||
;; catch this bad-boy in the COMPLR.
|
||
;; What do we say to the user anyway about such
|
||
;; crazzyness?
|
||
|
||
`(,(CAR SUM-EXP)
|
||
. ((LAMBDA (/0 N)
|
||
;; should be gensyms. WHY does GJC
|
||
;; lose like this?
|
||
(COND ((NOT (< N /0))
|
||
(DO ((,VAR /0 (1+ ,VAR))
|
||
(,SUM ,(START-VAL
|
||
FLAG
|
||
(CAR SUM-EXP))
|
||
,(CDR SUM-EXP)))
|
||
((< N ,VAR) ,SUM)
|
||
))
|
||
((= N (1- /0))
|
||
,(START-VAL FLAG (CAR SUM-EXP)))
|
||
(T
|
||
(INTERVAL-ERROR ',(caar form) /0 N))))
|
||
,(CDR /0)
|
||
,(CDR N)))))
|
||
(T
|
||
(LET* ((SUMARG (CDR (TR-LOCAL-EXP (CADR FORM) (CADDR FORM)
|
||
'$ANY)))
|
||
(VAR (CADDR FORM))
|
||
(FREE-VAR-INFO (TBOUND-FREE-VARS (FREE-LISP-VARS SUMARG))))
|
||
(SIDE-EFFECT-FREE-CHECK (CADR FREE-VAR-INFO)
|
||
(CADR FORM))
|
||
`($ANY . (DOSUM (FUNGEN&ENV-FOR-MEVALSUMARG
|
||
,(DELETE VAR (CAR FREE-VAR-INFO))
|
||
(,VAR)
|
||
,SUMARG
|
||
;; the original form is here for when we
|
||
;; get mevalsumarged, otherwise we use
|
||
;; the translated SUMARG when we get
|
||
;; MEVAL'ed.
|
||
,(CADR FORM))
|
||
',VAR ,(CDR /0) ,(CDR N) ,FLAG)))))))
|
||
|
||
|
||
(DEF%TR-INHERIT $SUM $PRODUCT)
|
||
|
||
|
||
|
||
;;; Makelist is a very sorry FSUBR. All these FSUBRS are just to avoid
|
||
;;; writing LAMBDA. But lots of users use MAKELIST now.
|
||
;;; MAKELIST(EXP,X,0,N) with 4 args it is an iteration, with three it
|
||
;;; is a mapping over a list (the third argument).
|
||
|
||
(DEF%TR $MAKELIST (FORM)
|
||
(SETQ FORM (CDR FORM))
|
||
(COND ((= (LENGTH FORM) 3)
|
||
(LET (((EXP X LIST) FORM)
|
||
(SUM (GENSYM))
|
||
(LIL (GENSYM)))
|
||
`($ANY . (DO ((,LIL (CDR ,(DTRANSLATE LIST)) (CDR ,LIL))
|
||
(,SUM NIL)
|
||
(,X))
|
||
((NULL ,LIL)
|
||
`((MLIST) ,@(NREVERSE ,SUM)))
|
||
(SETQ ,X (CAR ,LIL)
|
||
,SUM (CONS ,(CDR (TR-LOCAL-EXP EXP
|
||
X
|
||
(VALUE-MODE X)))
|
||
,SUM))))))
|
||
((= (LENGTH FORM) 4)
|
||
(LET (((EXP X /0 N) FORM)
|
||
(/00 (GENSYM))
|
||
(NN (GENSYM))
|
||
(SUM (GENSYM)))
|
||
(SETQ /0 (DTRANSLATE /0) ; I had forgotten this before!
|
||
N (DTRANSLATE N)) ; never noticed.
|
||
`($ANY . ((LAMBDA (,/00 ,NN)
|
||
; bogus -gjc
|
||
;(DECLARE (FIXNUM ,/00 ,NN))
|
||
(COND ((NOT (< ,NN ,/00))
|
||
(DO ((,X ,/00 (1+ ,X))
|
||
(,SUM
|
||
NIL
|
||
(CONS
|
||
,(CDR (TR-LOCAL-EXP EXP
|
||
X
|
||
'$FIXNUM))
|
||
|
||
,SUM)))
|
||
((> ,X ,NN)
|
||
`((MLIST) ,@(NREVERSE ,SUM)))
|
||
(DECLARE (FIXNUM ,X))))
|
||
(T
|
||
(INTERVAL-ERROR
|
||
'$MAKELIST ,/00 ,NN))))
|
||
,/0 ,N))))
|
||
(T
|
||
(MFORMAT *TRANSLATION-MSGS-FILES*
|
||
"Wrong number of args to MAKELIST")
|
||
(SETQ TR-ABORT T)
|
||
'($ANY . '$**ERROR**))))
|
||
|
||
(comment
|
||
|jpg;suprv >|
|
||
(DEFMFUN $KILL FEXPR (L) (MAPC 'KILL1 L) #+GC (GCTWA) '$DONE))
|
||
|
||
(DEF%TR $KILL (FORM)
|
||
(COND ($TR_WINDY
|
||
(TR-TELL "
|
||
Warning:" FORM
|
||
"Use of KILL in translated program is not recommended. See GJC for
|
||
a replacement form. Translating anyway though.")))
|
||
`($ANY . (APPLY '$KILL ',(CDR FORM))))
|
||
|
||
;;; Macsyma arrays are the biggest crock since STATUS PUNT NIL days.
|
||
;;; The basic idea of ARRAY(<frob>,type,dims...) is that
|
||
;;; if type is of
|
||
;;;(ASSQ (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
|
||
;;; ($FLOAT . FLONUM) ($FLONUM . FLONUM)))
|
||
;;; then the dims are evaluated. But, if type is not one of those,
|
||
;;; it "must" be a dim spec! Of course, I must make this "analysis"
|
||
;;; at translate time, in order to preserve referential transparency
|
||
;;; in compiled code.
|
||
|
||
(DEF%TR $ARRAY (FORM)
|
||
(SETQ FORM (CDR FORM))
|
||
(LET ((NAME (CAR FORM))
|
||
(SPECP (ASSQ (CADR FORM)
|
||
'(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM)
|
||
($FLOAT . FLONUM) ($FLONUM . FLONUM)))))
|
||
(COND (SPECP
|
||
`($ANY . (APPLY '$ARRAY (LIST ',NAME
|
||
',(CADR FORM)
|
||
,@(TR-ARGS (CDDR FORM))))))
|
||
(T
|
||
`($ANY . (APPLY '$ARRAY (LIST ',NAME
|
||
,@(TR-ARGS (CDR FORM)))))))))
|
||
|
||
|
||
(comment
|
||
(DEFMFUN $DEFINE FEXPR (L)
|
||
(COND ((OR (NULL L) (NULL (CDR L)) (CDDR L))
|
||
(ERLIST '|Wrong number of args to DEFINE|)))
|
||
(APPLY 'MDEFINE
|
||
(LIST (COND ((MQUOTEP (CAR L)) (CADAR L)) (T (DISP2 (CAR L)))) (MEVAL (CADR L))))))
|
||
|
||
;;; MDEFINE is an FSUBR also.
|
||
|
||
(DEF%TR $DEFINE (FORM)
|
||
(LET (((HEADER BODY) (CDR FORM)))
|
||
`($ANY . (APPLY 'MDEFINE
|
||
(LIST ',(COND ((MQUOTEP HEADER) (CADR HEADER))
|
||
(T (DISP2 HEADER)))
|
||
,(DTRANSLATE BODY))))))
|
||
|
||
|
||
;;; it seems TRANSL has all sorts of code for hacking some kind of
|
||
;;; $CRE mode. somehow there is no translate property for MRAT. who
|
||
;;; knows. anyway here is something in the mean time before this
|
||
;;; I have time to do up TRANSL correctly.
|
||
;;;(DEFUN MRATEVAL (X)
|
||
;;; ((LAMBDA (VARLIST)
|
||
;;; (COND (EVP (MEVAL ($RATDISREP X)))
|
||
;;; ((OR (AND $FLOAT $KEEPFLOAT) (NOT (ALIKE VARLIST (MAPCAR 'MEVAL VARLIST))))
|
||
;;; (RATF (MEVAL ($RATDISREP X))))
|
||
;;; (T X)))
|
||
;;; (CADDAR X)))
|
||
;;; EVP is a hack for $EV I think. The MEVAL down the varlist is to see if the
|
||
;;; variables have any values, if not, then the result of (ratf (meval ($ratdisrep)))
|
||
;;; will be alike to what you started with, so it is an efficiency hack! What a
|
||
;;; joke!
|
||
;;;(DEFPROP MRAT (LAMBDA (X) (MRATEVAL X)) MFEXPR*)
|
||
|
||
(def%tr mrat (form)
|
||
(let ((t-form (translate ($ratdisrep form))))
|
||
(cond ((memq (car t-form) '($float $fixnum $number)) t-form)
|
||
(t `($ANY . (RATF ,(CDR T-FORM)))))))
|
||
|
||
|
||
;;; The following special forms do not call the evaluator.
|
||
|
||
(DEF%TR $ARRAYINFO (FORM)
|
||
`($ANY . (MEVAL ',FORM)))
|
||
|
||
(DEF%TR $ALIAS $ARRAYINFO)
|
||
(DEF%TR $ALLOC $ARRAYINFO)
|
||
(DEF%TR $BATCH $ARRAYINFO)
|
||
(DEF%TR $BATCHLOAD $ARRAYINFO)
|
||
(DEF%TR $BATCON $ARRAYINFO)
|
||
(DEF%TR $CLOSEFILE $ARRAYINFO)
|
||
(DEF%TR $COMPFILE $ARRAYINFO)
|
||
(DEF%TR $DELFILE $ARRAYINFO)
|
||
(DEF%TR $DEMO $ARRAYINFO)
|
||
(DEF%TR $DEPENDENCIES $ARRAYINFO)
|
||
(DEF%TR $DESCRIBE $ARRAYINFO)
|
||
(DEF%TR $DISKFREE $ARRAYINFO)
|
||
(DEF%TR $DISKUSE $ARRAYINFO)
|
||
(DEF%TR $DISPFUN $ARRAYINFO)
|
||
(DEF%TR $DISPRULE $ARRAYINFO)
|
||
(DEF%TR $FILELENGTH $ARRAYINFO)
|
||
(DEF%TR $FILELIST $ARRAYINFO)
|
||
(DEF%TR $FUNDEF $ARRAYINFO)
|
||
(DEF%TR $FULLDISKUSE $ARRAYINFO)
|
||
(DEF%TR $GRADEF $ARRAYINFO)
|
||
(DEF%TR $LISTFILES $ARRAYINFO)
|
||
(DEF%TR $LOADFILE $ARRAYINFO)
|
||
(DEF%TR $LOADARRAYS $ARRAYINFO)
|
||
(DEF%TR $LOADPLOTS $ARRAYINFO)
|
||
(DEF%TR $MAKEATOMIC $ARRAYINFO)
|
||
(DEF%TR $NAMEFILE $ARRAYINFO)
|
||
(DEF%TR $NUMERVAL $ARRAYINFO)
|
||
(DEF%TR $OPTIONS $ARRAYINFO)
|
||
(DEF%TR $ORDERGREAT $ARRAYINFO)
|
||
(DEF%TR $ORDERLESS $ARRAYINFO)
|
||
(DEF%TR $PLOTMODE $ARRAYINFO)
|
||
(DEF%TR $PRIMER $ARRAYINFO)
|
||
(DEF%TR $PRINTDISKUSE $ARRAYINFO)
|
||
(DEF%TR $PRINTFILE $ARRAYINFO)
|
||
(DEF%TR $PRINTPROPS $ARRAYINFO)
|
||
(DEF%TR $PROPERTIES $ARRAYINFO)
|
||
(DEF%TR $PROPVARS $ARRAYINFO)
|
||
(DEF%TR $QLISTFILES $ARRAYINFO)
|
||
(DEF%TR $REMFILE $ARRAYINFO)
|
||
(DEF%TR $REARRAY $ARRAYINFO)
|
||
(DEF%TR $REMARRAY $ARRAYINFO)
|
||
(DEF%TR $REMFUNCTION $ARRAYINFO)
|
||
(DEF%TR $REMOVE $ARRAYINFO)
|
||
(DEF%TR $REMVALUE $ARRAYINFO)
|
||
(DEF%TR $RENAMEFILE $ARRAYINFO)
|
||
(DEF%TR $RESTORE $ARRAYINFO)
|
||
(DEF%TR $TRANSLATE $ARRAYINFO)
|
||
(DEF%TR $WRITEFILE $ARRAYINFO)
|
||
(DEF%TR $HARDCOPY $ARRAYINFO)
|
||
(DEF%TR $LABELS $ARRAYINFO)
|
||
(DEF%TR $SETUP_AUTOLOAD $ARRAYINFO)
|
||
(DEF%TR $TOBREAK $ARRAYINFO)
|
||
|
||
|
||
;; Local Modes:
|
||
;; Mode: LISP
|
||
;; Comment Col: 40
|
||
;; END:
|