1;;; -*-*cold-load:t;  Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12B HL12BI) 1-*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.

2;;; **	2Macros for defining functions and macros*

;; 11/13/86 DNG - Original version of this file.  Previously these things were
;;		  defined as special forms instead of macros.
;; 03/03/89 clm - In PROCESS-DEFUN-BODY, when making a named-lambda, don't assume
;;                Zetalisp mode if not in Common Lisp mode.  Someone may have created
;;                a new mode (spr 9291).

;; the most primitive way for defining macros. retained for older programs and used internally.
(DEFMACRO MACRO (FUNCTION-SPEC &ENVIRONMENT ENV &REST DEF)
 1 *(DECLARE (ARGLIST &QUOTE FUNCTION-SPEC LAMBDA-LIST &REST BODY))
  1"Define FUNCTION-SPEC as a macro; this is the most primitive way.
LAMBDA-LIST should specify TWO arguments the first of which gets the whole form (i.e. the
macro call) and the second is the optional environment (use IGNORE unless you
need to call MACROEXPAND or PARSE-BODY).  BODY is what is evaluated to produce
the expansion of the macro call.  Example:
  (MACRO FIRST (FORM IGNORE) `(CAR ,(CADR FORM)))
Note that (CAR FORM) would be the symbol FIRST, since FORM
is a call to the macro FIRST."*
  (LET* ((function-spec (STANDARDIZE-FUNCTION-SPEC function-spec))
	 (def (CONS 'MACRO (PROCESS-DEFUN-BODY function-spec def NIL ENV))))
    ;; Note: we don't need an (EVAL-WHEN (EVAL COMPILE LOAD) ...) here because
    ;;	the compiler knows that (FUNCTION (MACRO ...)) needs special
    ;;	compile-time handling [in function COMPILER:BUILD-DEBUG-INFO].
    `(PROGN (FDEFINE ',function-spec (FUNCTION ,def) t)
	    ',function-spec)))

(MACRO DEFUN (FORM &OPTIONAL ENVIRONMENT)
  (DECLARE (ARGLIST &QUOTE FUNCTION-SPEC LAMBDA-LIST &REST BODY))
  1"syntax: (DEFUN function-spec lambda-list [doc-string] . body)
  Define FUNCTION-SPEC to take args according to LAMBDA-LIST and compute value 
  using BODY. The syntax for LAMBDA-LIST is
   ( {var}* [&OPTIONAL {var| (var [initialization [supplied-var-p] ])}*]
            [&REST var]
            [&KEY {var| ( {var|(keyword var)} [initialization [supplied-var-p]])}
                  &allow-other-keys]
            [&AUX {var | (var initialization)}])
  An implicit BLOCK surrounds the body of the function so that
  (RETURN-FROM function-spec (VALUES...)) can be used to exit and pass back values."*
  (WHEN (< (LENGTH FORM) 3)
    (MACRO-REPORT-ARGS-ERROR FORM 2 NIL))
  (LET* ((NAME (STANDARDIZE-FUNCTION-SPEC (SECOND FORM)))
	 (ARGS-AND-BODY (CDDR FORM))
	 (DEF (PROCESS-DEFUN-BODY NAME ARGS-AND-BODY NIL ENVIRONMENT))
	 (QUOTED-NAME `(QUOTE ,NAME)))
    `(PROGN (FDEFINE ,QUOTED-NAME (FUNCTION ,DEF) T)
	    ,QUOTED-NAME) ))

;;; (DEFSUBST FOO (X) (AR-1 X 5)) is like a similar DEFUN
;;; except that the definition of FOO will be substituted in at compile time
;;; and FOO's argument variables eliminated by substitution.
;;; It is your responsibility to make sure that FOO's args
;;; are evaluated exactly once, in the right ordr, in FOO's body,
;;; and that the symbols used for the args do not appear except
;;; to represent the args.

(MACRO DEFSUBST (FORM &OPTIONAL ENVIRONMENT)
  1"Define SYMBOL as a substitutable function.
DEFSUBST is used like DEFUN, and the resulting function may be called
and will work just as if it had been defined with DEFUN.
However, the compiler will open-code calls to this function
by substituting the arguments specified in the call
into the function's body.  Be careful!  Read the info in the manual."*
  (DECLARE (ARGLIST &QUOTE SYMBOL LAMBDA-LIST &REST BODY))
  (WHEN (< (LENGTH FORM) 3)
    (MACRO-REPORT-ARGS-ERROR FORM 2 NIL))
  (LET* ((NAME (STANDARDIZE-FUNCTION-SPEC (SECOND FORM)))
	 (ARGS-AND-BODY (CDDR FORM))
	 (DEF (PROCESS-DEFUN-BODY NAME ARGS-AND-BODY T ENVIRONMENT)))
    (SETF (CAR DEF) (IF (COMMON-LISP-ON-P) 'NAMED-SUBST 'GLOBAL:NAMED-SUBST))
    (DOLIST (ELT (THIRD DEF))
      (WHEN (AND (MEMBER ELT LAMBDA-LIST-KEYWORDS :TEST #'EQ)
		 (NOT (MEMBER ELT '(&REST &OPTIONAL &EXTENSION) :TEST #'EQ)))
	(FERROR NIL "The defsubst ~S uses the lambda-list keyword ~S"
		NAME ELT)))
    ;; Note: we don't need an (EVAL-WHEN (EVAL COMPILE LOAD) ...) here because
    ;;	the compiler knows that NAMED-SUBST definitions need special
    ;;	compile-time handling [in function COMPILER:BUILD-DEBUG-INFO].
    `(PROGN (FDEFINE ',NAME (FUNCTION ,DEF) T)
	    ',NAME) ))

(DEFMACRO DEFF (FUNCTION-SPEC DEFINITION)
1  "Define FUNCTION-SPEC with its definition being the value of DEFINITION.*
\1(DEFF FOO '(LAMBDA (X) X)) is a useless but correct example and the
compiler would not compile the LAMBDA. (DEFF FOO 'BAR) makes FOO a synonym 
for BAR."*
  (DECLARE (ARGLIST &QUOTE FUNCTION-SPEC &EVAL DEFINITION))
  `(PROGN (FDEFINE ',function-spec ,definition T)
	  ',function-spec))

(DEFMACRO DEFF-MACRO (FUNCTION-SPEC DEFINITION)
1  "Define FUNCTION with definition DEFINITION, which should be a subst or macro.
If found in a file being compiled, this definition will be in effect
during compilation as well as when the compiled file is loaded.
That is how DEFF-MACRO differs from DEFF."*
  (DECLARE (ARGLIST &QUOTE FUNCTION-SPEC &EVAL DEFINITION))
  `(EVAL-WHEN (EVAL COMPILE LOAD)
     (FDEFINE ',function-spec ,definition T)
     ',function-spec))


(DEFMACRO DEF (FUNCTION-SPEC &REST DEFINING-FORMS)
  1"Define FUNCTION-SPEC by evaluating DEFINING-FORMS for effect.
This function does nothing, really.
It exists to identify to the editor where a function is being defined,
if the editor would not otherwise be able to figure it out."*
  (DECLARE (ARGLIST &QUOTE FUNCTION-SPEC &REST DEFINING-FORMS))
  `(PROGN (AND (RECORD-SOURCE-FILE-NAME ',FUNCTION-SPEC)
	       (PROGN . ,DEFINING-FORMS))
	  (EVAL-WHEN (COMPILE) (COMPILER:COMPILATION-DEFINE ',FUNCTION-SPEC))
	  ',FUNCTION-SPEC )
  )
(DEFPROP DEF T MAY-SURROUND-DEFUN)


(DEFCONSTANT FUNCTION-START-SYMBOLS
	  '(CLI:LAMBDA CLI:SUBST 
	    NAMED-LAMBDA NAMED-SUBST
	    GLOBAL:LAMBDA GLOBAL:NAMED-LAMBDA 
	    GLOBAL:SUBST  GLOBAL:NAMED-SUBST)
  1"A list starting with one of these symbols can be a function."*)


;; The following function is used only by the macros above.

(eval-when (compile load eval)
(DEFUN PROCESS-DEFUN-BODY (name vars+body &OPTIONAL no-implicit-block environment)
  "Given the name and the data, for a DEFUN, return a NAMED-LAMBDA form.
  NO-IMPLICIT-BLOCK inhibits creation of the automatic BLOCK around the BODY
  and is used for DEFSUBST."
  
  ;; In case DEFUN was called from compiled code,
  ;; and VARS+BODY is a stack list, copy it.
  (LET* ((vars+body (COPY-LIST vars+body))
	 (body (CDR vars+body))
	 (vars (CAR vars+body)))
    ;; extract declarations and the  doc-string  from <body> which is re-bound to the actual body
    (MULTIPLE-VALUE-BIND (body declarations-from-body doc-string)
	(PARSE-BODY body environment t)
      (LET ((complete-list-of-declarations LOCAL-DECLARATIONS)
	    decls-for-debug-info 
	    decls-for-body)
	;; Construct a list of declarations found in the body plus those in LOCAL-DECLARATIONS.
	;; This list will have the form, e.g. ((ARGLIST X Y Z) (SPECIAL BARF BAZ) (INLINE BLIP)).
	;; Some of these will be put back in  <body> and some will be moved to debugging-info
	(DOLIST (x declarations-from-body)
	  (DOLIST (y (CDR x))
	    (PUSH y complete-list-of-declarations)))
	(DOLIST (dcl complete-list-of-declarations)
	  (LET ((temp (CDR (ASSOC (CAR dcl) *DEBUG-STRUCT-LOCAL-DECLARATION-TYPES* :test #'EQ))))
	    (IF temp
		(SETQ decls-for-debug-info (LIST* temp (COPY-TREE (CDR dcl)) decls-for-debug-info)) ;; plist now
		(PUSH dcl  decls-for-body))))
	;;now the implicit block unless <no-implicit-block> or <name> is not literal
	(UNLESS (OR no-implicit-block (NOT (SYMBOLP name)))
	  (SETQ body `((block ,name . ,body))))
	;; add in declarations
	(WHEN decls-for-body
	  (SETQ body (CONS `(DECLARE . ,decls-for-body) body)))
	;; next add in doc string
	(WHEN doc-string
	  (SETQ body (CONS doc-string body)))
	;; make a named-lambda of the appropriate form  
	`(,(IF (ZETALISP-ON-P) 'global:named-lambda 'named-lambda)    ;; clm 03/03/89 
	  ,(IF (OR decls-for-debug-info (NOT (SYMBOLP name))) (list name decls-for-debug-info) name)
	  ,vars . ,body)
	))))
)