;;;-*-lisp-*-

(herald closure)

(eval-when (eval compile load)
	   (cond ((status feature complr)
		  (or (get 'closure-macros 'version)
		      (load '((graphs)closem)))
		  (*lexpr GCALL)
		  (*expr make-closure))
		 (t
		  (mapc '(lambda (u) (putprop u '((graphs)closem) 'autoload))
			'(open-GCALL self-GCALL defclosure make-closure-1)))))

(DEFUN CLOSURE-SUBR-HOOK (X1 X2 X3 X4 X5)
       ; this function MUST be compiled in order for the
       ; system to work.
       (FUNCALL (CLOSURE-NAME *SELF*) X1 X2 X3 X4 X5))
				    
(defun make-closure (name full-instance-vars full-instance-vals
			  pre-instance-vars pre-instance-vals)
       (let ((c
	      (make-closure-1 name name
			      subr-pointer (OR (get name 'subr)
					       (GET 'CLOSURE-SUBR-HOOK 'SUBR)
					       (ERROR "Can't hook" NAME))
			      full-instance-vars full-instance-vars
			      full-instance-vals full-instance-vals
			      pre-instance-vars `(*self* ,@pre-instance-vars)
			      pre-instance-vals pre-instance-vals)))
	      (push c (closure-pre-instance-vals c))
	      c))

(defun GCALL (f &optional x1 x2 x3 x4 x5)
       (open-GCALL f x1 x2 x3 x4 x5))

(defvar traced-closure-msgfile tyo)
(defvar traced-closure-linefeedp nil)

(defclosure traced-closure (x1 x2 x3 x4 x5)
	    ((level 0))
	    (sub-closure)
	    
	    (setq level (1+ level))
	    (setq traced-closure-linefeedp t)
	    (format traced-closure-msgfile
		    "~%~A ~A :~A ~:[~;<~A~:[>~;,~A~:[>~;,~A~:[>~;,~A>~]~]~]~]"
		    (closure-name sub-closure)
		    level
		    x1 x2 x2 x3 x3 x4 x4 x5 x5)
	    (let ((traced-closure-linefeedp nil))
		 (setq x1 (GCALL sub-closure x1 x2 x3 x4 x5))
		 (format traced-closure-msgfile
			 "~:[~2*~;~%~A ~A~] =>~A"
			 traced-closure-linefeedp
			 (closure-name sub-closure)
			 level
			 x1))
	    (setq level (1- level))
	    x1)

(defun make-traced-closure (sub-closure)
       (make-traced-closure-closure () (sub-closure sub-closure)))

(mapc '(lambda (u) (putprop u '((alan)dprint) 'autoload))
      '(describe dprint))

(defmap-self-GCALL fixnum 2)
(defmap-self-GCALL fixnum 4)
(defmap-self-GCALL flonum 2)
(defmap-self-GCALL flonum 4)