;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(macsyma-module trhook)


(LOAD-MACSYMA-MACROS PROCS)

(defprop trhook /5 version)

;;; This function needs to be in its own file.
;;; It forms a vital low-level part of the autoloading system of
;;; the macsyma->lisp translator. However, it is not itself
;;; a TRANSL-MODULE, since it is needed to implement TRANSL-MODULE.
;;; Various parts of the translator may be loaded, and in various
;;; orders, depending on what entry points are called.
;;; The entry points are in various files.

;;; Note: It wasn't obvious how to do this the first time
;;; - GJC.

;;; Autloadable Translation properties.  Needed for small address space systems
;;; only.  Figure out what to do for Twenex.  We really want a facility like
;;; this for all of Macsyma, where MDEFCOM is used to define a Macsyma
;;; user-level command, and an autoload property is automatically generated for
;;; the entrypoint. -cwh
;;; No kidding. DEF%TRFUN and DEF%TR does this for the TRANSL package. -gjc

#+PDP10
(DEF-PROCEDURE-PROPERTY
 AUTOLOAD-TRANSLATE ;; The trampoline for autoloading during translation.
 (LAMBDA (FORM)
	 (REMPROP (CAAR FORM) 'TRANSLATE)
	 (LET ((FILENAME (GET (CAAR FORM) 'AUTOLOAD-TRANSLATE)))
	      (COND (FILENAME
		     (LOAD-AND-TELL FILENAME))
		    ((GET (CAAR FORM) 'AUTOLOAD)
		     (LOAD-FUNCTION (CAAR FORM) T))))
	 (TRANSLATE FORM))
 SUBR)

(DEFUN MAP1-PUT-IF-NIL (LIST-OF-SYMBOLS PROP NAME)
       (DO ((SYM))
	   ((NULL LIST-OF-SYMBOLS) PROP)
	   (SETQ SYM (POP LIST-OF-SYMBOLS))
	   (IF (NOT (GET SYM NAME))
	       (PUTPROP SYM PROP NAME))))

(defun put-map (l p &optional (it t))
       (do () ((null l))
	   (let ((sym (pop l)))
		(if (symbolp sym)
		    (setf (get sym p) it)))))

(defun special fexpr (l) (put-map l 'special))
(defun *lexpr fexpr (l) (put-map l '*lexpr))
(defun *expr fexpr (l) (put-map l '*expr))
(defun *fexpr fexpr (l) (put-map l '*fexpr))
(defun fixnum fexpr (l) (put-map l 'mode '$fixnum))
(defun flonum fexpr (l) (put-map l 'mode '$float))