mirror of
https://github.com/PDP-10/its.git
synced 2026-01-18 17:16:59 +00:00
72 lines
2.1 KiB
Common Lisp
72 lines
2.1 KiB
Common Lisp
;;;-*-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)
|