mirror of
https://github.com/PDP-10/its.git
synced 2026-03-31 03:32:04 +00:00
151 lines
4.4 KiB
Common Lisp
Executable File
151 lines
4.4 KiB
Common Lisp
Executable File
;;; -*- Mode: Lisp; Package: Macsyma -*-
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; Compilation environment for TRANSLATED MACSYMA code. ;;;
|
|
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(macsyma-module mdefun macro)
|
|
|
|
;(TRANSL-MODULE MDEFUN) IS CORRECT. But doesn't work in the MPRELU
|
|
;; environment.
|
|
|
|
(load-macsyma-macros transm)
|
|
|
|
;;; $FIX_NUM_ARGS_FUNCTION $VARIABLE_NUM_ARGS_FUNCTION.
|
|
|
|
(DEFVAR *KNOWN-FUNCTIONS-INFO-STACK* NIL
|
|
"When MDEFUN-TR expands it puts stuff here for MFUNCTION-CALL
|
|
to use.")
|
|
|
|
(DEFVAR *UNKNOWN-FUNCTIONS-INFO-STACK* NIL
|
|
"When MFUNCTION-CALL expands without info from
|
|
*KNOWN-FUNCTIONS-INFO-STACK* it puts stuff here to be barfed
|
|
at the end of compilation.")
|
|
|
|
(DEFUN (MDEFUN-TR MACRO) (FORM)
|
|
(error "obsolete macro form, please retranslate source code"
|
|
form 'fail-act))
|
|
|
|
(DEFUN (MDEFUN MACRO)(FORM)
|
|
(error "obsolete macro form, please retranslate source code"
|
|
form 'fail-act))
|
|
|
|
;;; DEFMTRFUN will be the new standard.
|
|
;;; It will punt macsyma fexprs since the macro scheme is now
|
|
;;; available. I have tried to generalize this enough to do
|
|
;;; macsyma macros also.
|
|
|
|
;;; (DEFMTRFUN-EXTERNAL ($FOO <mode> <property> <&restp>))
|
|
|
|
|
|
#+PDP10
|
|
(DEFUN COMPILER-STATE () COMPILER-STATE)
|
|
#+LISPM
|
|
(DEFUN COMPILER-STATE () (Y-OR-N-P "Is COMPILER-STATE true?"))
|
|
#-(OR LISPM PDP10)
|
|
(DEFUN COMPILER-STATE () T)
|
|
|
|
|
|
(defun (defmtrfun-external macro) (form)
|
|
(let (((name mode prop restp) (cadr form)))
|
|
#+pdp10
|
|
(and (eq prop 'mdefine) (COMPILER-STATE)
|
|
(PUSH-INFO NAME (COND (RESTP 'LEXPR)
|
|
(T 'EXPR))
|
|
*KNOWN-FUNCTIONS-INFO-STACK*))
|
|
`(declare (,(cond (restp '*lexpr) (t '*expr))
|
|
,name)
|
|
;; FLONUM declaration is most important
|
|
;; for numerical work on the pdp-10.
|
|
,@(IF (AND (EQ PROP 'MDEFINE) (EQ MODE '$FLOAT))
|
|
`((FLONUM (,NAME))))
|
|
)
|
|
))
|
|
|
|
;;; (DEFMTRFUN ($FOO <mode> <property> <&restp>) <ARGL> . BODY)
|
|
;;; If the MODE is numeric it should do something about the
|
|
;;; numebr declarations for compiling. Also, the information about the
|
|
;;; modes of the arguments should not be thrown away.
|
|
|
|
;;; For the LISPM this sucks, since &REST is built-in.
|
|
|
|
(DEFUN (DEFMTRFUN MACRO) (FORM)
|
|
(LET (( ((NAME MODE PROP RESTP . ARRAY-FLAG) ARGL . BODY) (CDR FORM))
|
|
(DEF-HEADER))
|
|
|
|
(AND ARRAY-FLAG
|
|
;; old DEFMTRFUN's might have this extra bit NIL
|
|
;; new ones will have (NIL) or (T)
|
|
(SETQ ARRAY-FLAG (CAR ARRAY-FLAG)))
|
|
|
|
(SETQ DEF-HEADER
|
|
(COND ((EQ PROP 'MDEFINE)
|
|
(COND (ARRAY-FLAG #-LISPM `(,NAME A-EXPR A-SUBR)
|
|
#+LISPM `(:PROPERTY ,NAME A-SUBR))
|
|
(T NAME)))
|
|
(T `(,NAME TRANSLATED-MMACRO))))
|
|
#+PDP10
|
|
(AND (EQ PROP 'MDEFINE) (COMPILER-STATE) (NOT ARRAY-FLAG)
|
|
(PUSH-INFO NAME (COND (RESTP 'LEXPR)
|
|
(T 'EXPR))
|
|
*KNOWN-FUNCTIONS-INFO-STACK*))
|
|
|
|
`(PROGN 'COMPILE
|
|
,@(AND (NOT ARRAY-FLAG) `((REMPROP ',NAME 'TRANSLATE)))
|
|
,@(AND MODE `((DEFPROP ,NAME ,MODE
|
|
,(COND (ARRAY-FLAG 'ARRAYFUN-MODE)
|
|
(T 'FUNCTION-MODE)))))
|
|
,@(COND (ARRAY-FLAG
|
|
;; when loading in hashed array properties
|
|
;; most exist or be created. Other
|
|
;; array properties must be consistent if
|
|
;; they exist.
|
|
`((INSURE-ARRAY-PROPS ',NAME ',MODE
|
|
',(LENGTH ARGL)))))
|
|
,@(COND ((AND (EQ PROP 'MDEFINE) (NOT ARRAY-FLAG))
|
|
`((COND ((STATUS FEATURE MACSYMA)
|
|
(mputprop ',name t
|
|
,(COND
|
|
((NOT RESTP)
|
|
''$fixed_num_args_function)
|
|
(T
|
|
''$variable_num_args_function)))))
|
|
,(COND ((NOT RESTP)
|
|
`(ARGS ',NAME '(NIL . ,(LENGTH ARGL))))))))
|
|
(DEFUN ,DEF-HEADER ,(COND ((NOT RESTP) ARGL)
|
|
(T '|mlexpr NARGS|))
|
|
,@(COND ((NOT RESTP)
|
|
BODY)
|
|
(t
|
|
(LET ((NL (1- (LENGTH ARGL))))
|
|
`((COND ((< |mlexpr NARGS| ,NL)
|
|
($ERROR
|
|
'ERROR ',NAME
|
|
'| takes no less than |
|
|
,NL
|
|
',(COND ((= NL 1)
|
|
'| argument.|)
|
|
(T
|
|
'| arguments.|))))
|
|
(T
|
|
((LAMBDA ,ARGL
|
|
,@BODY)
|
|
;; this conses up the
|
|
;; calls to ARGS and LISTIFY.
|
|
,@(DO ((J 1 (1+ J))
|
|
(P-ARGL NIL))
|
|
((> J NL)
|
|
(PUSH
|
|
`(CONS
|
|
'(MLIST)
|
|
(LISTIFY
|
|
(- ,NL
|
|
|mlexpr NARGS|)))
|
|
P-ARGL)
|
|
(NREVERSE P-ARGL))
|
|
(PUSH `(ARG ,J)
|
|
P-ARGL)))))))))))))
|
|
|
|
|
|
|