mirror of
https://github.com/PDP-10/its.git
synced 2026-02-10 18:29:48 +00:00
66 lines
2.1 KiB
Common Lisp
Executable File
66 lines
2.1 KiB
Common Lisp
Executable File
;;; FUNCEL -*-Mode:Lisp;Package:SI;Lowercase:T-*-
|
|
;;; ****************************************************************
|
|
;;; *** MacLISP ******** Function-Cell Hacking *********************
|
|
;;; ****************************************************************
|
|
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
|
|
;;; ****************************************************************
|
|
|
|
(herald FUNCEL /2)
|
|
|
|
(eval-when (eval compile)
|
|
(load '((lisp) subload)))
|
|
|
|
(eval-when (eval load compile)
|
|
(subload EXTEND))
|
|
|
|
;;;; FMAKUNBOUND, FSYMEVAL, and FSET, for maclisp
|
|
|
|
|
|
(defclass* SUBR SUBR-CLASS MACLISP-PRIMITIVE-CLASS)
|
|
(defclass* LSUBR LSUBR-CLASS MACLISP-PRIMITIVE-CLASS)
|
|
|
|
(defmethod* (:PRINT-SELF SUBR-CLASS) (obj stream () () )
|
|
(si:print-extend obj (si:xref obj 0) stream))
|
|
|
|
(defmethod* (:PRINT-SELF LSUBR-CLASS) (obj stream () () )
|
|
(si:print-extend obj (si:xref obj 0) stream))
|
|
|
|
(defun FMAKUNBOUND (sym)
|
|
(if *RSET (or (and sym (symbolp sym))
|
|
(check-type sym #'SYMBOLP 'FMAKUNBOUND)))
|
|
(prog (prop)
|
|
A (if (null (setq prop (getl sym '(SUBR LSUBR EXPR MACRO))))
|
|
(return () ))
|
|
(remprop sym (car prop))
|
|
(go A)) ;Avoid lossage when symbol has both MACRO and SUBR
|
|
sym)
|
|
|
|
(defun FSYMEVAL (a &aux pl fun)
|
|
(do ()
|
|
((and (symbolp a)
|
|
(setq pl (getl a '(SUBR LSUBR MACRO EXPR))))
|
|
() )
|
|
(setq a (error "Not a function name -- FSYMEVAL" a 'WRNG-TYPE-ARG)))
|
|
(setq fun (cadr pl))
|
|
(caseq (car pl)
|
|
((SUBR LSUBR)
|
|
(si:extend (if (eq (car pl) 'SUBR) SUBR-CLASS LSUBR-CLASS)
|
|
fun
|
|
(args a)))
|
|
(EXPR fun)
|
|
(MACRO `(MACRO . ,fun))))
|
|
|
|
|
|
(defun FSET (sym val &aux (type (typep val)))
|
|
(fmakunbound sym)
|
|
(cond ((and (eq type 'LIST) (memq (car val) '(MACRO LAMBDA)))
|
|
(cond ((eq (car val) 'MACRO) (putprop sym (cdr val) 'MACRO))
|
|
((eq (car val) 'LAMBDA) (putprop sym val 'EXPR))))
|
|
((eq type 'SYMBOL) (putprop sym val 'EXPR))
|
|
((memq (setq type (type-of val)) '(SUBR LSUBR))
|
|
(putprop sym (si:xref val 0) type)
|
|
(args sym (si:xref val 1)))
|
|
('T (error "Not a function? - FSET" val)))
|
|
val)
|
|
|