mirror of
https://github.com/PDP-10/its.git
synced 2026-01-17 16:53:23 +00:00
102 lines
2.4 KiB
Common Lisp
102 lines
2.4 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
||
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
||
(macsyma-module nummac macro)
|
||
|
||
;;; macros for "numerical" code.
|
||
|
||
|
||
(DEFVAR *FLOAT-GENCALL-STACK* NIL "set up by GCALL-LET")
|
||
|
||
#+Multics
|
||
(defmacro flonum-identity (x)
|
||
`(+$ ,x))
|
||
#+Multics
|
||
(defmacro fixnum-identity (x)
|
||
`(+ ,x))
|
||
|
||
(DEFUN GET-S (IND V)
|
||
(CDR (ASSQ V (CDR (ASSQ IND *FLOAT-GENCALL-STACK*)))))
|
||
(DEFUN PUT-S (IND VAL V)
|
||
(LET ((FRAME (ASSQ IND *FLOAT-GENCALL-STACK*)))
|
||
(COND (FRAME
|
||
(SETF (CDR FRAME)
|
||
(CONS (CONS V VAL) (CDR FRAME))))
|
||
(T
|
||
(PUSH `(,IND (,V . ,VAL)) *FLOAT-GENCALL-STACK*)))))
|
||
|
||
(comment '|
|
||
;What you do is
|
||
(gcall-bind (f g h) ...
|
||
; and then inside the body of this form you can do
|
||
(gcall f x)
|
||
; which will be a fast call like (funcall f x)
|
||
; but with hacks.
|
||
)
|
||
|)
|
||
|
||
(DEFMACRO GCALL (F X &optional (erst nil erst-p))
|
||
`(#+maclisp
|
||
FLONUM-IDENTITY
|
||
#+lispm
|
||
PROGN
|
||
(COND #+maclisp
|
||
(,(GET-S F 'SUBRCALL-FLONUMP)
|
||
(SUBRCALL FLONUM ,F ,X))
|
||
#+maclisp
|
||
(,(GET-S F 'SUBRCALLP)
|
||
(SUBRCALL T ,F ,X))
|
||
(,(GET-S F 'LISPCALLP)
|
||
(FUNCALL ,F ,X))
|
||
(T (FMAPPLY ,F (LIST ,X)
|
||
,@(if erst-p (list erst) nil))))))
|
||
|
||
(EVAL-WHEN (COMPILE EVAL)
|
||
(DEFMACRO CONCAT (A B)
|
||
`(IMPLODE (APPEND (EXPLODEN ,A) (EXPLODEN ,B)))))
|
||
|
||
(DEFMACRO GCALL-BIND (FUNLIST &REST BODY)
|
||
`(LET* (,@(APPLY 'APPEND
|
||
(MAPCAR #'(LAMBDA (FUN)
|
||
(AND (ATOM FUN) (SETQ FUN (LIST FUN FUN)))
|
||
(LET* ((FF (CAR FUN))
|
||
(FS (CADR FUN))
|
||
#+maclisp
|
||
(SUBRCALL-FLONUMP
|
||
(CONCAT '|subr$p~| FS))
|
||
|
||
#+maclisp
|
||
(SUBRCALLP (CONCAT '|subrp~| FS))
|
||
(LISPCALLP (CONCAT '|lispp~| FS)))
|
||
#+maclisp
|
||
(PUT-S FF SUBRCALL-FLONUMP
|
||
'SUBRCALL-FLONUMP)
|
||
#+maclisp
|
||
(PUT-S FF SUBRCALLP 'SUBRCALLP)
|
||
(PUT-S FF LISPCALLP 'LISPCALLP)
|
||
`(#+maclisp
|
||
(,SUBRCALL-FLONUMP (SUBRCALL$P ,FS))
|
||
#+maclisp
|
||
(,SUBRCALLP (SUBRCALLP ,FS))
|
||
(,LISPCALLP (NOT (MACSYMACALLP ,FS)))
|
||
#+maclisp
|
||
(,FF (COND (,SUBRCALLP ,SUBRCALLP)
|
||
(T ,FS)))
|
||
#+lispm
|
||
(,FF ,FS))))
|
||
FUNLIST)))
|
||
,@BODY))
|
||
|
||
|
||
#+maclisp
|
||
(DEFMACRO AREF$ (&REST ARGS)
|
||
`(ARRAYCALL FLONUM ,@ARGS))
|
||
#+maclisp
|
||
(DEFMACRO ASET$ (VAL &REST ARGS)
|
||
`(STORE (ARRAYCALL FLONUM ,@ARGS) ,VAL))
|
||
|
||
|
||
|
||
|
||
|