;;-*-LISP-*-
;; For mapping over da objects in da FASL files
;; of Macsyma. 6:36pm  Wednesday, 15 July 1981 
;; -George Carrette.

;; Functions of interest:

;; (MACSYMA-RUNTIME-MODULES) returns list of module names.

;; (MAP-OVER-FASL-INFO-IN-MODULE
;;   <FUNCTION> <MODULE-NAME> &optional <FASLREADOPEN-OPTIONS>)
;;   During the mapping the following special variables are bound:
;;    CURRENT-MODULE
;;    MACSYMA-SOURCE-FILE
;;    FASLREAD-TYPE

;; (ADDPROP? <SYMBOL> <OBJECT> <KEY>) good for gathering info.


(eval-when (eval compile)
  (or (get 'defmfile 'version)
      (load '((Maxtul)defile))))

(declare (special faslread-type)
	 (*expr faslread faslreadclose)
	 (*lexpr faslreadopen))


(defvar current-module)
(defvar macsyma-source-file)
(defvar faslread-object)

(DEFUN ADDPROP? (SYMBOL OBJECT KEY)
  ;; Returns NIL if it is info already known, non-nil if not known.
  (LET ((L (GET SYMBOL KEY)))
    (IF (MEMQ OBJECT L) 
	NIL
	(PUTPROP SYMBOL (CONS OBJECT L) KEY))))

(defun macsyma-runtime-modules ()
  (sort (mapcan #'(lambda (u)
		    (if (not (macro-file-p u))
			(list (macsyma-source-file-name u))))
		macsyma-source-files)
	#'alphalessp))

(DEFUN MAP-OVER-FASL-INFO-IN-MODULE (F CURRENT-MODULE
				       &OPTIONAL
				       (OPTIONS () OPTIONS-P))
  (LET ((MACSYMA-SOURCE-FILE (ASS #'(LAMBDA (A B)
				      (EQ A (MACSYMA-SOURCE-FILE-NAME B)))
				  CURRENT-MODULE
				  MACSYMA-SOURCE-FILES)))
    (IF (NULL MACSYMA-SOURCE-FILE)
	(FORMAT MSGFILES "~&; Module not a macsyma-source-file : ~S~%"
		current-module)
	(LET ((SOURCE-FILE (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-DIR))
					 ,(MACSYMA-SOURCE-FILE-NAME)
					 >)))
	      (FASL-FILES (CONS (MACSYMA-SOURCE-FILE-NAME)
				(MACSYMA-SOURCE-FILE-SPLIT))))
	  (IF (MEMQ (CAR FASL-FILES) (CDR FASL-FILES))
	      (SETQ FASL-FILES (CDR FASL-FILES)))
	  (FORMAT MSGFILES
		  "~&; For source file ~A~%" source-file)
	  (do ((l fasl-files (cdr l)))
	      ((null l))
	    (LET ((Filename (NAMESTRING `((DSK ,(MACSYMA-SOURCE-FILE-FASL-DIR))
					  ,(CAR L) FASL)))
		  (ff-object))
	      (IF (NOT (PROBEF Filename))
		  (FORMAT MSGFILES
			  "~&; Possible file ~A not found.~%" Filename)
		  (unwind-protect
		   (map-over-fasl-info-in-object
		    f
		    (setq ff-object
			  (if options-p
			      (faslreadopen filename options)
			      (faslreadopen filename))))
		   (faslreadclose ff-object)))))))))

(defun map-over-fasl-info-in-object (f ff-object)
  (let ((faslread-type nil)
	(faslread-object ff-object)
	#+complr
	(fast-f (or (and (symbolp f)
			 (eq (car (getl f '(subr lsubr expr fexpr fsubr)))
			     'subr)
			 (get f 'subr))
		    ;; ask me about this code someday. -gjc
		    (boole 7 13._27.
			   (lsh 1 23.)
			   (maknum f)))))
    (do ((form))
	(nil)
      (setq form (faslread ff-object))
      (if (eq faslread-type 'eof) (return nil))
      #+complr (subrcall nil fast-f form)
      #-complr (funcall f form)
      )))