31
31
(if (and (not (atom form))
32
32
(symbolp (car form))
33
33
;; we want an fboundp which gives T for special forms too.
34
(OR (fboundp (car form))
35
#+NIL (SI:MACRO-DEFINITION (CAR FORM))
36
#+NIL (EQ (CAR FORM) 'SPECIAL)))
34
(or (fboundp (car form))
35
#+nil (si:macro-definition (car form))
36
#+nil (eq (car form) 'special)))
40
(defmacro optimizing-declarations (dcls &body body) dcls
41
#+NIL `(locally (declare (optimize ,@dcls)) ,@body)
42
#-NIL `(progn ,@body))
40
;;(defmacro optimizing-declarations (dcls &body body) dcls
41
;; #+NIL `(locally (declare (optimize ,@dcls)) ,@body)
42
;; #-NIL `(progn ,@body))
44
44
;; All these updating macros should be made from the same generalized
45
45
;; push/pop scheme as I mentioned to LispForum. As they are defined now
46
46
;; they have inconsistent return-values and multiple-evaluations of
49
(DEFMACRO ADDL (ITEM LIST)
50
`(OR (MEMQ ,ITEM ,LIST) (SETQ ,LIST (CONS ,ITEM ,LIST))))
52
#-Multics (PROGN 'COMPILE
55
(DEFMACRO INCREMENT (COUNTER &OPTIONAL INCREMENT)
57
`(SETF ,COUNTER (f+ ,COUNTER ,INCREMENT))
58
`(SETF ,COUNTER (f1+ ,COUNTER))))
61
(DEFMACRO DECREMENT (COUNTER &OPTIONAL DECREMENT)
63
`(SETF ,COUNTER (f- ,COUNTER ,DECREMENT))
64
`(SETF ,COUNTER (f1- ,COUNTER))))
66
(DEFMACRO COMPLEMENT (SWITCH) `(SETF ,SWITCH (NOT ,SWITCH)))
68
) ;; End of Lispm conditionalization.
49
(defmacro addl (item list)
50
`(or (memq ,item ,list) (setq ,list (cons ,item ,list))))
52
#-multics (progn 'compile
53
(defmacro increment (counter &optional increment)
55
`(setf ,counter (f+ ,counter ,increment))
56
`(setf ,counter (f1+ ,counter))))
59
(defmacro decrement (counter &optional decrement)
61
`(setf ,counter (f- ,counter ,decrement))
62
`(setf ,counter (f1- ,counter))))
64
(defmacro complement (switch)
65
`(setf ,switch (not ,switch)))
67
) ;; End of Lispm conditionalization.
71
70
;; 'writefilep' and 'ttyoff' are system independent ways of expressing
75
74
;; it works in most cases.
77
76
(eval-when (compile eval load)
78
(defvar writefilep #-Franz '^R #+Franz 'ptport)
77
(defvar writefilep #-franz '^r #+franz 'ptport)
81
80
;; (IFN A B) --> (COND ((NOT A) B))
82
81
;; (IFN A B C D) --> (COND ((NOT A) B) (T C D))
83
82
;; (IFN A B) is equivalent to (OR A B) as (IF A B) is equivalent to (AND A B).
85
(DEFMACRO IFN (PREDICATE THEN . ELSE)
86
(COND ((NULL ELSE) `(COND ((NOT ,PREDICATE) ,THEN)))
87
(T `(COND ((NOT ,PREDICATE) ,THEN) (T . ,ELSE)))))
84
(defmacro ifn (predicate then . else)
85
(cond ((null else) `(cond ((not ,predicate) ,then)))
86
(t `(cond ((not ,predicate) ,then) (t . ,else)))))
89
(DEFMACRO FN (BVL &REST BODY)
90
`(FUNCTION (LAMBDA ,BVL . ,BODY)))
88
(defmacro fn (bvl &rest body)
89
`(function (lambda ,bvl . ,body)))
92
91
;; Like PUSH, but works at the other end.
94
(DEFMACRO TUCHUS (LIST OBJECT)
95
`(SETF ,LIST (NCONC ,LIST (NCONS ,OBJECT))))
93
(defmacro tuchus (list object)
94
`(setf ,list (nconc ,list (ncons ,object))))
97
96
;; Copy a single cons, the top level and all levels (repectively) of a piece of
98
97
;; list structure. Something similar for strings, structures, etc. would be
99
98
;; useful. These functions should all be open-coded subrs.
101
(DEFMACRO COPY-CONS (CONS)
103
`(CONS (CAR ,CONS) (CDR ,CONS))
104
(LET ((VAR (GENSYM)))
105
`(LET ((,VAR ,CONS)) `(CONS (CAR ,VAR) (CDR ,VAR))))))
100
(defmacro copy-cons (cons)
102
`(cons (car ,cons) (cdr ,cons))
103
(let ((var (gensym)))
104
`(let ((,var ,cons)) `(cons (car ,var) (cdr ,var))))))
107
(DEFMACRO COPY-TOP-LEVEL (LIST)
108
#+(or cl NIL) `(COPY-LIST ,LIST)
109
#-(or cl NIL) `(APPEND ,LIST NIL))
106
(defmacro copy-top-level (list)
107
#+(or cl nil) `(copy-list ,list)
108
#-(or cl nil) `(append ,list nil))
111
110
;; (DEFMACRO COPY-ALL-LEVELS (LIST)
112
111
;; #+(or cl NIL) `(COPY-TREE ,LIST)
115
114
;; Old names kept around for compatibility.
117
(DEFMACRO COPY1* (LIST)
118
#+(or cl NIL) `(COPY-LIST ,LIST)
119
#-(or cl NIL) `(APPEND ,LIST NIL))
120
(DEFMACRO COPY1 (LIST)
121
#+(or cl NIL) `(COPY-LIST ,LIST)
122
#-(or cl NIL) `(APPEND ,LIST NIL))
124
(DEFMACRO COPY (LIST)
125
#+(or cl nil symbolics) `(COPY-TREE ,LIST)
126
#-(or cl nil symbolics) `(SUBST NIL NIL ,LIST))
116
(defmacro copy1* (list)
117
#+(or cl nil) `(copy-list ,list)
118
#-(or cl nil) `(append ,list nil))
119
(defmacro copy1 (list)
120
#+(or cl nil) `(copy-list ,list)
121
#-(or cl nil) `(append ,list nil))
123
(defmacro copy (list)
124
#+(or cl nil symbolics) `(copy-tree ,list)
125
#-(or cl nil symbolics) `(subst nil nil ,list))
128
127
;; Use this instead of GETL when looking for "function" properties,
129
128
;; i.e. one of EXPR, SUBR, LSUBR, FEXPR, FSUBR, MACRO.
130
129
;; Use FBOUNDP, SYMBOL-FUNCTION, or FMAKUNBOUND if possible.
132
(DEFMACRO GETL-FUN (FUN L)
133
#+MacLisp `(GETL ,FUN ,L)
134
#+CL `(GETL-LM-FCN-PROP ,FUN ,L)
135
#+Franz `(GETL-FRANZ-FCN-PROP ,FUN ,L)
136
#+NIL `(GETL-NIL-FCN-PROP ,FUN ,L)
131
(defmacro getl-fun (fun l)
132
#+maclisp `(getl ,fun ,l)
133
#+cl `(getl-lm-fcn-prop ,fun ,l)
134
#+franz `(getl-franz-fcn-prop ,fun ,l)
135
#+nil `(getl-nil-fcn-prop ,fun ,l)
139
138
;; Non-destructive versions of DELQ and DELETE. Already part of NIL
140
139
;; and LMLisp. These should be rewritten as SUBRS and placed
141
140
;; in UTILS. The subr versions can be more memory efficient.
143
;#-(OR Lispm NIL Multics Franz cl)
144
;(DEFMACRO REMQ (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
145
; (IF COUNTING? `(DELQ ,ITEM (APPEND ,LIST NIL) ,COUNT)
146
; `(DELQ ,ITEM (APPEND ,LIST NIL))))
149
(DEFMACRO REMQ (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
150
`(remove ,item ,list :test 'eq ,@ (and counting? `(:count ,count))))
153
;(DEFMACRO ZL-REMOVE (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
154
; `(remove ,item ,list :test 'equal ,@ (and counting? `(:count ,count))))
156
;#-(OR Lispm NIL Multics Franz)
157
;(DEFMACRO zl-REMOVE (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
158
; (IF COUNTING? `(zl-DELETE ,ITEM (APPEND ,LIST NIL) ,COUNT)
159
; `(zl-DELETE ,ITEM (APPEND ,LIST NIL))))
161
#-Lispm (DEFMACRO CATCH-ALL (FORM) `(CATCH NIL ,FORM))
142
;;#-(OR Lispm NIL Multics Franz cl)
143
;;(DEFMACRO REMQ (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
144
;; (IF COUNTING? `(DELQ ,ITEM (APPEND ,LIST NIL) ,COUNT)
145
;; `(DELQ ,ITEM (APPEND ,LIST NIL))))
148
(defmacro remq (item list &optional (count () counting?))
149
`(remove ,item ,list :test 'eq ,@ (and counting? `(:count ,count))))
152
;;(DEFMACRO ZL-REMOVE (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
153
;; `(remove ,item ,list :test 'equal ,@ (and counting? `(:count ,count))))
155
;;#-(OR Lispm NIL Multics Franz)
156
;;(DEFMACRO zl-REMOVE (ITEM LIST &OPTIONAL (COUNT () COUNTING?))
157
;; (IF COUNTING? `(zl-DELETE ,ITEM (APPEND ,LIST NIL) ,COUNT)
158
;; `(zl-DELETE ,ITEM (APPEND ,LIST NIL))))
160
#-lispm (defmacro catch-all (form) `(catch nil ,form))
163
162
;; (EXCH A B) exchanges the bindings of A and B
164
163
;; Maybe it should turn into (PSETF A B B A)?
166
(DEFMACRO EXCH (X Y) `(SETF ,X (PROG1 ,Y (SETF ,Y ,X))))
165
(defmacro exch (x y) `(setf ,x (prog1 ,y (setf ,y ,x))))
168
167
;; These are here for old code only.
169
168
;; Use FIFTH rather than CADDDDR. Better, use DEFSTRUCT.
171
#-Franz (DEFMACRO CADDADR (X) `(CAR (CDDADR ,X)))
172
#-Franz (DEFMACRO CADDDDR (X) `(CAR (CDDDDR ,X)))
170
#-franz (defmacro caddadr (x) `(car (cddadr ,x)))
171
#-franz (defmacro caddddr (x) `(car (cddddr ,x)))
174
173
;; The following is a bit cleaner than the kludgy (PROGN 'COMPILE . <FORMS>)
176
(DEFMACRO COMPILE-FORMS (&REST <FORMS>) `(PROGN 'COMPILE . ,<FORMS>))
175
(defmacro compile-forms (&rest <forms>) `(progn 'compile . ,<forms>))
179
177
;; The following macros pertain only to Macsyma.
181
179
;; Widely used macro for printing error messages. We should be able
186
184
;; Obsolete. Use MERROR.
188
(DEFMACRO ERLIST (MESSAGE)
189
(MAXIMA-ERROR "ERLIST is obsolete, all calls to it have been removed, so where
186
(defmacro erlist (message)
187
(maxima-error "ERLIST is obsolete, all calls to it have been removed, so where
190
188
did you dig this one up loser?" message))
192
190
;; All functions are present on non-autoloading systems. Definition
193
191
;; for autoloading systems is in SUPRV.
194
192
;; If you have dynamic linking you might as well take advantage of it.
197
(DEFMACRO FIND-FUNCTION (FUNCTION) FUNCTION NIL)
195
(defmacro find-function (function) function nil)
199
197
;; Facility for loading auxilliary macro files such as RATMAC or MHAYAT.
200
198
;; Global macro files are loaded by the prelude file.
202
#+LISPM (DEFUN MACRO-DIR (X) (FORMAT NIL "LMMAXQ;~A QFASL" X))
203
#+PDP10 (DEFUN MACRO-DIR (X) `((LIBMAX) ,X))
204
#+Franz (defun macro-dir (x) (cond ((cdr (zl-ASSOC x '((rzmac . "rz//macros")
205
(mhayat . "rat//mhayat")
206
(ratmac . "rat//ratmac")))))
200
#+lispm (defun macro-dir (x) (format nil "LMMAXQ;~A QFASL" x))
201
#+pdp10 (defun macro-dir (x) `((libmax) ,x))
202
#+franz (defun macro-dir (x) (cond ((cdr (zl-assoc x '((rzmac . "rz//macros")
203
(mhayat . "rat//mhayat")
204
(ratmac . "rat//ratmac")))))
207
205
(t (concat "libmax//" x))))
208
#+NIL (defun macro-dir (x) (merge-pathname-defaults x "[VASL]"))
206
#+nil (defun macro-dir (x) (merge-pathname-defaults x "[VASL]"))
210
(comment Sample definition only on
211
ITS see "LIBMAX;MODULE"
212
LISPM see "LMMAX;SYSDEF"
213
NIL see "VAXMAX;VAXCL"
215
Franz see "/usr/lib/lisp/machacks.l"
217
(defmacro macsyma-module (name &rest options)
218
(maybe-load-macros options)
219
(maybe-load-declarations options)
220
`(eval-when (compile eval load)
221
(print '(loading ,name) msgfiles)
222
(defprop ,name t loaded?)
223
,@(maybe-have-some-runtime-options options)))
208
(comment sample definition only on
209
its see "LIBMAX;MODULE"
210
lispm see "LMMAX;SYSDEF"
211
nil see "VAXMAX;VAXCL"
213
franz see "/usr/lib/lisp/machacks.l"
215
(defmacro macsyma-module (name &rest options)
216
(maybe-load-macros options)
217
(maybe-load-declarations options)
218
`(eval-when (compile eval load)
219
(print '(loading ,name) msgfiles)
220
(defprop ,name t loaded?)
221
,@(maybe-have-some-runtime-options options)))
226
224
;; Except on the Lisp Machine, load the specified macro files.
227
225
;; On the Lisp Machine, the DEFSYSTEM facility is used for loading
230
228
;; is far from fool-proof. See LMMAX;SYSDEF for the Lispm
231
229
;; definition of MACSYMA-MODULE.
234
(DEFUN LOAD-MACSYMA-MACROS-AT-RUNTIME (&REST L)
235
(MAPCAR #'(LAMBDA (X)
236
(IF (GET X 'MACSYMA-MODULE)
238
(ERROR "Missing Macsyma macro file -- ~A" X)))
241
(DEFUN LOAD-MACSYMA-MACROS-AT-RUNTIME (&REST L)
242
(MAPCAR #'load-when-needed L))
244
(DEFMACRO LOAD-MACSYMA-MACROS (&REST MACRO-FILES)
245
`(COMMENT *MACRO*FILES*
246
,(APPLY #'LOAD-MACSYMA-MACROS-AT-RUNTIME MACRO-FILES)))
232
(defun load-macsyma-macros-at-runtime (&rest l)
233
(mapcar #'(lambda (x)
234
(if (get x 'macsyma-module)
236
(error "Missing Maxima macro file -- ~A" x)))
239
(defun load-macsyma-macros-at-runtime (&rest l)
240
(mapcar #'load-when-needed l))
242
(defmacro load-macsyma-macros (&rest macro-files)
243
`(comment *macro*files*
244
,(apply #'load-macsyma-macros-at-runtime macro-files)))
250
248
(defmacro find-documentation-file (x)
251
249
(cond ((eq x 'manual)
252
250
`(let ((filep (probe-file (list (catenate macsyma-dir ">documentation")
255
(t (MAXIMA-ERROR "Cannot MAXIMA-FIND the Macsyma manual")))))
253
(t (maxima-error "Cannot `maxima-find' the Macsyma manual")))))
256
254
((eq x 'manual-index)
257
255
`(let ((filep (probe-file (list (catenate macsyma-dir ">documentation")
258
"macsyma.index.lisp"))))
260
(t (MAXIMA-ERROR "Cannot MAXIMA-FIND the Macsyma manual index")))))
261
(t (MAXIMA-ERROR "Unknown documentation: " x))))
256
"macsyma.index.lisp"))))
258
(t (maxima-error "Cannot `maxima-find' the Macsyma manual index")))))
259
(t (maxima-error "Unknown documentation: " x))))
264
262
(defmacro load-documentation-file (x)
265
263
`(load (find-documentation-file ,x)))
267
265
;;;Reset the stream to its starting position.
268
266
(defmacro rewind-stream (stream)
270
#-(or LispM NIL) `(filpos ,stream 0)
271
;#+LispM `(send ,stream ':rewind)
272
#+cl `(file-position ,stream 0)
273
#+NIL `(open ,stream))
268
#-(or lispm nil) `(filpos ,stream 0)
269
;;#+LispM `(send ,stream ':rewind)
270
#+cl `(file-position ,stream 0)
271
#+nil `(open ,stream))
275
273
;; Used to temporarily bind contexts in such a way as to not cause
276
274
;; the context garbage collector to run. Used when you don't want to
282
280
(defmacro with-new-context (sub-context &rest forms)
283
281
`(let ((context (context ,@sub-context)))
285
(context-unwinder))))
283
(context-unwinder))))
288
285
;; For creating a macsyma evaluator variable binding context.
289
286
;; (MBINDING (VARIABLES &OPTIONAL VALUES FUNCTION-NAME)
292
(DEFMACRO MBINDING (VARIABLE-SPECIFICATION &REST BODY &AUX (TEMP (GENSYM)))
293
`(LET ((,TEMP ,(CAR VARIABLE-SPECIFICATION)))
294
;; Don't optimize out this temporary, even if (CAR VARIABLE-SPECICIATION)
295
;; is an ATOM. We don't want to risk side-effects.
296
,(CASE (LENGTH VARIABLE-SPECIFICATION)
298
`(MBINDING-SUB ,TEMP ,TEMP NIL ,@BODY))
300
`(MBINDING-SUB ,TEMP ,(CADR VARIABLE-SPECIFICATION) NIL ,@BODY))
302
`(MBINDING-SUB ,TEMP ,(CADR VARIABLE-SPECIFICATION)
303
,(CADDR VARIABLE-SPECIFICATION)
306
(MAXIMA-ERROR "Bad variable specification:" variable-specification)))))
289
(defmacro mbinding (variable-specification &rest body &aux (temp (gensym)))
290
`(let ((,temp ,(car variable-specification)))
291
;; Don't optimize out this temporary, even if (CAR VARIABLE-SPECICIATION)
292
;; is an ATOM. We don't want to risk side-effects.
293
,(case (length variable-specification)
295
`(mbinding-sub ,temp ,temp nil ,@body))
297
`(mbinding-sub ,temp ,(cadr variable-specification) nil ,@body))
299
`(mbinding-sub ,temp ,(cadr variable-specification)
300
,(caddr variable-specification)
303
(maxima-error "Bad variable specification:" variable-specification)))))
308
(DEFVAR MBINDING-USAGE
309
#+(and PDP10 Maclisp) 'PROG1
310
#+(and Multics Maclisp) 'UNWIND-PROTECT
313
#+NIL 'UNWIND-PROTECT
305
(defvar mbinding-usage
306
#+(and pdp10 maclisp) 'prog1
307
#+(and multics maclisp) 'unwind-protect
310
#+nil 'unwind-protect
316
(DEFMACRO MBINDING-SUB (VARIABLES VALUES FUNCTION-NAME &REST BODY
320
`(PROG1 (PROGN (MBIND ,VARIABLES ,VALUES ,FUNCTION-NAME) ,@BODY)
321
(MUNBIND ,VARIABLES)))
325
(PROGN (MBIND ,VARIABLES ,VALUES ,FUNCTION-NAME)
328
(IF ,WIN (MUNBIND ,VARIABLES)))))
330
`(LET ((,WIN (MBINDING-CHECK ,VARIABLES ,VALUES ,FUNCTION-NAME)))
335
(MAXIMA-ERROR "Unknown setting of MBINDING-USAGE" MBINDING-USAGE))))
338
(DEFMACRO MDEFPROP (A B C) `(MPUTPROP ',A ',B ',C))
340
#-Franz ;; Franz uses a function definition in COMM.
341
;; For MLISTP its arg is known not to be an atom.
342
;; Otherwise, just use $LISTP.
343
;; MLISTP exists just to support a Franz hack, so you can just
345
(DEFMACRO MLISTP (X) `(EQ (CAAR ,X) 'MLIST))
313
(defmacro mbinding-sub (variables values function-name &rest body
317
`(prog1 (progn (mbind ,variables ,values ,function-name) ,@body)
318
(munbind ,variables)))
322
(progn (mbind ,variables ,values ,function-name)
325
(if ,win (munbind ,variables)))))
327
`(let ((,win (mbinding-check ,variables ,values ,function-name)))
332
(maxima-error "Unknown setting of `mbinding-usage'" mbinding-usage))))
335
(defmacro mdefprop (a b c) `(mputprop ',a ',b ',c))
337
#-franz ;; Franz uses a function definition in COMM.
338
;; For MLISTP its arg is known not to be an atom.
339
;; Otherwise, just use $LISTP.
340
;; MLISTP exists just to support a Franz hack, so you can just
342
(defmacro mlistp (x) `(eq (caar ,x) 'mlist))
347
344
;; How About MTYPEP like (MTYPEP EXP 'TAN) or (MTYPEP EXP '*) - Jim.
348
345
;; Better, (EQ (MTYPEP EXP) 'TAN).
352
(AND (NOT (ATOM THING)) (EQ (CAAR THING) '%TAN))))
349
(and (not (atom thing)) (eq (caar thing) '%tan))))
356
(AND (NOT (ATOM THING)) (EQ (CAAR THING) '%ATAN))))
353
(and (not (atom thing)) (eq (caar thing) '%atan))))
358
355
;; Macros used in LIMIT, DEFINT, RESIDU.
359
356
;; If we get a lot of these, they can be split off into a separate macro
362
(DEFMACRO REAL-INFINITYP (X) `(MEMQ ,X REAL-INFINITIES))
364
(DEFMACRO INFINITYP (X) `(MEMQ ,X INFINITIES))
366
(DEFMACRO REAL-EPSILONP (X) `(MEMQ ,X INFINITESIMALS))
368
(DEFMACRO FREE-EPSILONP (X)
369
`(DO ((ONE-EPS INFINITESIMALS (CDR ONE-EPS)))
371
(IF (NOT (FREE (CAR ONE-EPS) ,X)) (RETURN ()))))
373
(DEFMACRO FREE-INFP (X)
374
`(DO ((ONE-INF INFINITIES (CDR ONE-INF)))
376
(IF (NOT (FREE (CAR ONE-INF) ,X)) (RETURN ()))))
378
(DEFMACRO INF-TYPEP (X)
379
`(CAR (AMONGL INFINITIES ,X)))
381
(DEFMACRO HOT-COEF (P)
382
`(PDIS (CADDR (CADR (RAT-NO-RATFAC ,P)))))
359
(defmacro real-infinityp (x) `(memq ,x real-infinities))
361
(defmacro infinityp (x) `(memq ,x infinities))
363
(defmacro real-epsilonp (x) `(memq ,x infinitesimals))
365
(defmacro free-epsilonp (x)
366
`(do ((one-eps infinitesimals (cdr one-eps)))
368
(if (not (free (car one-eps) ,x)) (return ()))))
370
(defmacro free-infp (x)
371
`(do ((one-inf infinities (cdr one-inf)))
373
(if (not (free (car one-inf) ,x)) (return ()))))
375
(defmacro inf-typep (x)
376
`(car (amongl infinities ,x)))
378
(defmacro hot-coef (p)
379
`(pdis (caddr (cadr (rat-no-ratfac ,p)))))
384
381
;; Special form for declaring Macsyma external variables. It may be used for
385
382
;; User level variables, or those referenced by other Lisp programs.
402
399
;; so if *reset-var* is true defmvar will restore the original value on lispm--Wfs
403
400
;; definition is in commac.
405
#-(or Franz ITS lispm cl)
406
(DEFMACRO DEFMVAR (VARIABLE &OPTIONAL (INITIAL-VALUE NIL IV-P) DOCUMENTATION
407
&REST FLAGS &AUX DEFINER TYPE)
408
DOCUMENTATION FLAGS ;; Ignored certain places.
409
(SETQ DEFINER #+(or Multics ) 'DEFCONST
410
#-(or Multics ) 'DEFVAR)
412
(SETQ TYPE (COND ((MEMQ 'fixnum FLAGS) 'fixnum)
413
((MEMQ 'flonum FLAGS) 'flonum)
415
#+NIL (macsyma-defmvar-declarations variable flags)
418
`(,DEFINER ,VARIABLE ,INITIAL-VALUE
419
#+NIL ,@(AND DOCUMENTATION `(,DOCUMENTATION)))
420
`(,DEFINER ,VARIABLE #+LISPM () ))
421
#-NIL ,@(IF TYPE `((DECLARE (,TYPE ,VARIABLE))))))
402
#-(or franz its lispm cl)
403
(defmacro defmvar (variable &optional (initial-value nil iv-p) documentation
404
&rest flags &aux definer type)
405
documentation flags ;; Ignored certain places.
406
(setq definer #+(or multics ) 'defconst
407
#-(or multics ) 'defvar)
409
(setq type (cond ((memq 'fixnum flags) 'fixnum)
410
((memq 'flonum flags) 'flonum)
412
#+nil (macsyma-defmvar-declarations variable flags)
415
`(,definer ,variable ,initial-value
416
#+nil ,@(and documentation `(,documentation)))
417
`(,definer ,variable #+lispm () ))
418
#-nil ,@(if type `((declare (,type ,variable))))))
425
(Defmacro DEFMFUN (function &body REST &aux .n.)
426
#+NIL (macsyma-defmfun-declarations function rest)
427
`(DEFUN ,FUNCTION ,REST))
422
(defmacro defmfun (function &body rest &aux .n.)
423
#+nil (macsyma-defmfun-declarations function rest)
424
`(defun ,function ,rest))
430
(DEFPROP DEFMSPEC "Macsyma special form" SI:DEFINITION-TYPE-NAME)
427
;;(DEFPROP DEFMSPEC "Macsyma special form" SI:DEFINITION-TYPE-NAME)
432
429
;; Special form for declaring Macsyma external procedures. Version for ITS
433
430
;; is in LIBMAX;DEFINE.
439
(DEFMACRO DEFMSPEC (FUNCTION . REST)
436
(defmacro defmspec (function . rest)
441
(DEFUN-prop ( ,FUNCTION MFEXPR*) . ,REST)
442
#+lispm (SI::RECORD-SOURCE-FILE-NAME ',FUNCTION 'DEFMSPEC)))
438
(defun-prop ( ,function mfexpr*) . ,rest)
439
#+lispm (si::record-source-file-name ',function 'defmspec)))
445
;(DEFMACRO DEFMSPEC (FUNCTION . REST)
446
; `(LOCAL-DECLARE ((SYS:FUNCTION-PARENT ,FUNCTION DEFMSPEC))
447
; (DEFUN (:PROPERTY ,FUNCTION MFEXPR*) . ,REST)
448
; (SI:RECORD-SOURCE-FILE-NAME ',FUNCTION 'DEFMSPEC)
442
;;(DEFMACRO DEFMSPEC (FUNCTION . REST)
443
;; `(LOCAL-DECLARE ((SYS:FUNCTION-PARENT ,FUNCTION DEFMSPEC))
444
;; (DEFUN (:PROPERTY ,FUNCTION MFEXPR*) . ,REST)
445
;; (SI:RECORD-SOURCE-FILE-NAME ',FUNCTION 'DEFMSPEC)
452
449
;;How bout the following for a replacement for the defmspec type.
458
455
;;a macro but they needed to be told anyway.--wfs
462
;(defmacro defmspec (fn (aa) &rest rest &aux ans help )
463
; (setq help (intern (format nil "~A-AUX" fn)))
465
; (list ;;copy-list aa
466
; `(defmacro ,fn (&rest ,aa &aux e)(setq ,aa (copy-list ,aa))
467
; (setq e (cons (list ',fn) ,aa))
468
; `(meval* '(,', help ',e)))
469
; `(defun ,help (,aa) . ,rest)))
470
; `(progn 'compile . , ans))
459
;;(defmacro defmspec (fn (aa) &rest rest &aux ans help )
460
;; (setq help (intern (format nil "~A-AUX" fn)))
462
;; (list ;;copy-list aa
463
;; `(defmacro ,fn (&rest ,aa &aux e)(setq ,aa (copy-list ,aa))
464
;; (setq e (cons (list ',fn) ,aa))
465
;; `(meval* '(,', help ',e)))
466
;; `(defun ,help (,aa) . ,rest)))
467
;; `(progn 'compile . , ans))
473
;(defmspecial $ssum (l) (setq l (cdr l))
474
; (if (= (length l) 4)
475
; (dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
470
;;(defmspecial $ssum (l) (setq l (cdr l))
471
;; (if (= (length l) 4)
472
;; (dosum (car l) (cadr l) (meval (caddr l)) (meval (cadddr l)) t)
473
;; (wna-err '$$sum)))
479
476
;;; The following MAUTOLOAD macro makes setting up autoload props for files
498
495
;;; Note that the first arg must be of the form (FN2 DEV DIR) if a file
499
496
;;; mask is being used; this macro could be much more elaborate.
502
(DEFMACRO MAUTOLOAD (FN2-DEV-DIR &REST MASTER-LIST)
503
`(DOLIST (L ',MASTER-LIST)
504
(DO ((FILE (IF (ATOM (CAR L))
505
(CONS (CAR L) ,FN2-DEV-DIR)
507
(FUNLIST (CDR L) (CDR FUNLIST)))
509
(PUTPROP (CAR FUNLIST) FILE 'AUTOLOAD))))
499
;;(DEFMACRO MAUTOLOAD (FN2-DEV-DIR &REST MASTER-LIST)
500
;; `(DOLIST (L ',MASTER-LIST)
501
;; (DO ((FILE (IF (ATOM (CAR L))
502
;; (CONS (CAR L) ,FN2-DEV-DIR)
504
;; (FUNLIST (CDR L) (CDR FUNLIST)))
506
;; (PUTPROP (CAR FUNLIST) FILE 'AUTOLOAD))))
512
(DEFMACRO SYS-DEFAULTF (X) `(DEFAULTF ,X))
509
(defmacro sys-defaultf (x) `(defaultf ,x))
513
510
;;; For #+Multics a function definition for SYS-DEFAULTF can be found
516
513
(defmacro sys-user-id ()
517
#+Franz '(getenv '|USER|)
514
#+franz '(getenv '|USER|)
519
#+Multics '(status uname)
520
#-(or Franz Multics lispm) '(status userid))
516
#+multics '(status uname)
517
#-(or franz multics lispm) '(status userid))
522
519
(defmacro sys-free-memory ()
523
#-(or Multics lispm) '(status memfree)
524
#+(or Multics lispm) 10000.) ;This should look at the pdir size
525
;and mung it to give a good approximation.
520
#-(or multics lispm) '(status memfree)
521
#+(or multics lispm) 10000.) ;This should look at the pdir size
522
;and mung it to give a good approximation.
532
529
;; `(,sym ,tag ,value)
533
530
;; '`((PUTPROP ,nsym ,nvalue ,ntag))))
536
(defsetf MGET ((() sym tag) value) T
537
(eval-ordered* '(nsym ntag nvalue)
539
'`((MPUTPROP ,nsym ,nvalue ,ntag))))
542
(defsetf $GET ((() sym tag) value) T
543
(eval-ordered* '(nsym ntag nvalue)
545
'`(($PUT ,nsym ,nvalue ,ntag))))
548
(defsetf mget (expr value)
549
`(mputprop ,(cadr expr) ,value ,(caddr expr)))
552
(defsetf $get (expr value)
553
`($put ,(cadr expr) ,value ,(caddr expr)))
556
(DEFPROP MGET SETF-MGET SI:SETF-SUBR)
558
(DEFPROP $GET SETF-$GET SI:SETF-SUBR)
560
;;DIFFERENT version of setf on Multics and LM ...Bummer... -JIM 3/4/81
562
(defsetf MGET (sym tag) value
563
`(MPUTPROP ,sym ,value ,tag))
565
(DEFMFUN MGET (ATOM IND)
566
(LET ((PROPS (AND (SYMBOLP ATOM) (GET ATOM 'MPROPS))))
567
(AND PROPS (GETf (cdr PROPS) IND))))
533
;;(defsetf MGET ((() sym tag) value) T
534
;; (eval-ordered* '(nsym ntag nvalue)
535
;; `(,sym ,tag ,value)
536
;; '`((MPUTPROP ,nsym ,nvalue ,ntag))))
539
;;(defsetf $GET ((() sym tag) value) T
540
;; (eval-ordered* '(nsym ntag nvalue)
541
;; `(,sym ,tag ,value)
542
;; '`(($PUT ,nsym ,nvalue ,ntag))))
545
;;(defsetf mget (expr value)
546
;; `(mputprop ,(cadr expr) ,value ,(caddr expr)))
549
;;(defsetf $get (expr value)
550
;; `($put ,(cadr expr) ,value ,(caddr expr)))
553
;;(DEFPROP MGET SETF-MGET SI:SETF-SUBR)
555
;;(DEFPROP $GET SETF-$GET SI:SETF-SUBR)
557
;;;DIFFERENT version of setf on Multics and LM ...Bummer... -JIM 3/4/81
559
;;(defsetf MGET (sym tag) value
560
;; `(MPUTPROP ,sym ,value ,tag))
562
(defmfun mget (atom ind)
563
(let ((props (and (symbolp atom) (get atom 'mprops))))
564
(and props (getf (cdr props) ind))))
570
(defsetf MGET (sym tag) (value)
571
`(MPUTPROP ,sym ,value ,tag))
567
(defsetf mget (sym tag) (value)
568
`(mputprop ,sym ,value ,tag))
573
570
(defmacro old-get (plist tag)
574
571
`(getf (cdr ,plist) ,tag))
577
(defsetf $GET (sym tag) value
578
`($PUT ,sym ,value ,tag))
574
;;(defsetf $GET (sym tag) value
575
;; `($PUT ,sym ,value ,tag))
580
(DEFMFUN $GET (ATOM IND) (PROP1 '$GET ATOM NIL IND))
577
(defmfun $get (atom ind) (prop1 '$get atom nil ind))
583
(defsetf $GET (sym tag) (value)
584
`($PUT ,sym ,value ,tag))
586
;#+(and LISPM (not (or cl ti)))
587
;(DEFUN (:PROPERTY MGET SI:SETF) (REF VAL)
588
; `(MPUTPROP ,(SECOND REF) ,VAL ,(THIRD REF)))
590
;#+(and LISPM (not (or cl ti)))
591
;(DEFUN (:PROPERTY $GET SI:SETF) (REF VAL)
592
; `($PUT ,(SECOND REF) ,VAL ,(THIRD REF)))
580
(defsetf $get (sym tag) (value)
581
`($put ,sym ,value ,tag))
583
;;#+(and LISPM (not (or cl ti)))
584
;;(DEFUN (:PROPERTY MGET SI:SETF) (REF VAL)
585
;; `(MPUTPROP ,(SECOND REF) ,VAL ,(THIRD REF)))
587
;;#+(and LISPM (not (or cl ti)))
588
;;(DEFUN (:PROPERTY $GET SI:SETF) (REF VAL)
589
;; `($PUT ,(SECOND REF) ,VAL ,(THIRD REF)))
594
591
(defmacro initialize-random-seed ()
595
#+(or PDP10 NIL) '(sstatus random 0)
596
#+CL () ;;(si:random-initialize si:random-array) obsolete. what now?
592
;; #+(or PDP10 NIL) '(sstatus random 0)
593
#+cl () ;;(si:random-initialize si:random-array) obsolete. what now?
599
596
;; These idiot macros are used in some places in macsyma.
602
599
;; NIL (common-lisp) has the nth accessors through to tenth, the rest
603
600
;; frobs through to rest5. However i had thought that the latter were
604
601
;; obsolete, and had been going to flush them. --gsb
606
(DEFMACRO EIGHTH (FORM) `(CADDDR (CDDDDR ,FORM)))
608
(DEFMACRO NINTH (FORM) `(CAR (CDDDDR (CDDDDR ,FORM))))
610
(DEFMACRO TENTH (FORM) `(CADR (CDDDDR (CDDDDR ,FORM))))
612
(DEFMACRO REST5 (FORM) `(CDR (CDDDDR ,FORM)))
613
(DEFMACRO REST6 (FORM) `(CDDR (CDDDDR ,FORM)))
603
(defmacro eighth (form) `(cadddr (cddddr ,form)))
605
(defmacro ninth (form) `(car (cddddr (cddddr ,form))))
607
(defmacro tenth (form) `(cadr (cddddr (cddddr ,form))))
609
(defmacro rest5 (form) `(cdr (cddddr ,form)))
610
(defmacro rest6 (form) `(cddr (cddddr ,form)))
615
612
;;; We should probably move these into the compatibility package on
619
615
(defmacro *break (breakp mess)
620
616
`(apply 'break `(,,mess ,',breakp)))
622
618
;;; To satisfy GJC's speed mainia I resisted changing these in the
626
(defmacro +tyi (&rest args)
630
(defmacro +tyo (&rest args)
633
;;; Let the compiler know that x is a fixnum. I guess it will also
634
;;; then optimize the call to +.
636
(defmacro fixnum-identity (x)
622
;;(defmacro +tyi (&rest args)
626
;;(defmacro +tyo (&rest args)
629
;;;; Let the compiler know that x is a fixnum. I guess it will also
630
;;;; then optimize the call to +.
632
;;(defmacro fixnum-identity (x)
639
635
;;this was not called.
640
;(defmacro get-symbol-array-pointer (x)
642
; #+nil `(si:get-symbol-array-pointer ,x)
643
; #+cl `(symbol-array ,x)
644
; #+maclisp `(get ,x 'array))
636
;;(defmacro get-symbol-array-pointer (x)
637
;; #+franz `(getd ,x)
638
;; #+nil `(si:get-symbol-array-pointer ,x)
639
;; #+cl `(symbol-array ,x)
640
;; #+maclisp `(get ,x 'array))
647
643
(defmacro mdefprop (sym val indicator)
648
644
`(mputprop ',sym ',val ',indicator))
651
(DEFMFUN MPUTPROP (ATOM VAL IND)
652
(LET ((PROPS (GET ATOM 'MPROPS)))
653
(IF (NULL PROPS) (PUTPROP ATOM (SETQ PROPS (NCONS NIL)) 'MPROPS))
654
(PUTPROP PROPS VAL IND)))
647
(defmfun mputprop (atom val ind)
648
(let ((props (get atom 'mprops)))
649
(if (null props) (putprop atom (setq props (ncons nil)) 'mprops))
650
(putprop props val ind)))
added
removed
src/maxmac.lisp
