mirror of
https://github.com/PDP-10/its.git
synced 2026-01-21 10:13:35 +00:00
120 lines
4.1 KiB
Common Lisp
Executable File
120 lines
4.1 KiB
Common Lisp
Executable File
;;;-*-lisp-*-
|
|
;;; Using the /#-SYMBOLIC-CHARACTERS-TABLE as a way of specifying options.
|
|
;;; The main use of this is to be able to specify options to functions
|
|
;;; symbolically without fear of wasting symbol space in the maclisp
|
|
;;; environment, and without the hair of macro expansions.
|
|
;;; 7:16pm Sunday, 22 February 1981 -GJC
|
|
|
|
;;; N.B. Since the symbolic translation is done at read time, and since
|
|
;;; the implementation allows options from different sets to map into
|
|
;;; the same fixnum (in order that the fixnums may be most likey INUMS,
|
|
;;; which do not take up any extra space) validity of options is only
|
|
;;; checked in the obvious-call case of
|
|
;;; (FOOBAR #\<OPTION-SYMBOL> <VALUE> #\<OPTION-SYMBOL> <VALUE> ...)
|
|
;;; and this if and only if nobody has foolishly macroexpanded the
|
|
;;; arguments to FOOBAR before the syntax-checking SOURCE-TRANS property
|
|
;;; is invoked by the compiler. Oh yeah, you only get this error checking
|
|
;;; in the compiler, so much for people who debug code using the interpreter.
|
|
|
|
(OR (GET 'SHARPM 'VERSION) (LOAD '((LISP)SHARPM)))
|
|
|
|
(HERALD OPTDEF)
|
|
|
|
(DEFVAR OPTION-SETS NIL "List of symbols which have option properties")
|
|
|
|
(DECLARE (SPECIAL /#-SYMBOLIC-CHARACTERS-TABLE
|
|
;; we assume that the implementation of #\FOO is that
|
|
;; FOO is looked up in an ALIST which is the value
|
|
;; of this variable. This is true in Maclisp, and
|
|
;; will be in NIL. Off hand I don't know what to do
|
|
;; about this on the lisp machine.
|
|
))
|
|
|
|
(DEFUN ENTER-/#-SYMBOL (SYMBOL N)
|
|
(LET ((CELL (ASSQ SYMBOL /#-SYMBOLIC-CHARACTERS-TABLE)))
|
|
(IF CELL (SETF (CDR CELL) N)
|
|
(PUSH (CONS SYMBOL N)
|
|
/#-SYMBOLIC-CHARACTERS-TABLE))))
|
|
|
|
(DEFUN (|op| MACRO) (FORM)
|
|
;; this macro does NOT want to displace, has no need of memoization for speed.
|
|
(OR (GET (CADDR FORM)
|
|
(CADR FORM))
|
|
(ERROR (LIST "has no" (CADDR FORM) "option") (CADR FORM))))
|
|
|
|
;; N.B. I am aware that the macro definition does not take effect inside
|
|
;; a QUOTE. However, a useratoms hook would, in the compiler, therefore
|
|
;; we must conclude that something is wrong with the implementation of
|
|
;; quote in the interpreter.
|
|
|
|
(progn 'compile
|
|
;; interface to the hackish maclisp grinder.
|
|
|
|
(defun (|op| grindmacro) ()
|
|
(declare (special l m))
|
|
(princ "#\") (princ (caddr l)))
|
|
|
|
(defprop |op|
|
|
+internal-dwim-predictfun
|
|
grindpredict)
|
|
|
|
(defun (|op| grindflatsize) (l)
|
|
(+ 2 (flatsize (caddr l))))
|
|
)
|
|
|
|
|
|
(DEFUN OPTIONS-CHECK (FORM)
|
|
;; this catches most errors.
|
|
(DO ((SET (CAR FORM))
|
|
(ARGL (NTHCDR (1+ (OR (GET (CAR FORM) 'NUMBER-OF-LEADING-ARGUMENTS)
|
|
0))
|
|
FORM)
|
|
(CDDR ARGL)))
|
|
((NULL ARGL)
|
|
(VALUES FORM NIL))
|
|
(LET ((OPTION (CAR ARGL)))
|
|
(COND ((ATOM OPTION))
|
|
((EQ '|op| (CAR OPTION))
|
|
(OR (EQ (CADR OPTION) SET)
|
|
(ERROR (LIST "has option from outside set" OPTION)
|
|
FORM)))))))
|
|
|
|
(DEFUN ENTER-OPTION-SYMBOL (SET SYMBOL)
|
|
(DO ((L OPTION-SETS (CDR L)))
|
|
((NULL L))
|
|
(IF (MEMQ SYMBOL (GET (CAR L) 'OPTIONS))
|
|
;; this need not be an error, it could simply use the
|
|
;; existing GOEDEL number on the option symbol if it did not
|
|
;; conflict with the numbers already used by the SET in question.
|
|
;; If it did conflict then we have a problem.
|
|
;; Those familar with Pascal will recall a similar problem with
|
|
;; set implementations in that language.
|
|
;; You can't get something for nothing.
|
|
(ERROR (LIST "is already defined as an option for" (CAR L))
|
|
SYMBOL)))
|
|
(PUTPROP SYMBOL (LENGTH (GET SET 'OPTIONS)) SET)
|
|
(ENTER-/#-SYMBOL SYMBOL `(|op| ,SET ,SYMBOL))
|
|
(PUSH SYMBOL (GET SET 'OPTIONS)))
|
|
|
|
|
|
(DEFUN SETUP-OPTIONS (NAME NUMBER-OF-LEADING-ARGUMENTS OPTIONS)
|
|
(OR (MEMQ NAME OPTION-SETS) (PUSH NAME OPTION-SETS))
|
|
(OR (MEMQ 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS))
|
|
(PUSH 'OPTIONS-CHECK (GET NAME 'SOURCE-TRANS)))
|
|
(PUTPROP NAME NIL 'OPTIONS)
|
|
(PUTPROP NAME NUMBER-OF-LEADING-ARGUMENTS 'NUMBER-OF-LEADING-ARGUMENTS)
|
|
(MAPC #'(LAMBDA (OPTION)
|
|
(ENTER-OPTION-SYMBOL NAME OPTION))
|
|
OPTIONS))
|
|
|
|
(SETUP-OPTIONS 'P-READ 1
|
|
'(STOP-CHARS
|
|
NUMBER-OF-CHARS
|
|
ECHO-P
|
|
COMPLETION-CHAR
|
|
COMPLETION-ALIST
|
|
COMPLETION-QUERY-CHAR
|
|
COMPLETION-QUERY-STREAM
|
|
STOP-FUNCTION
|
|
CHAR-TRANSLATION-FUNCTION))
|
|
|