4.3BSD/usr/lib/lisp/syntax.l
(setq rcs-syntax-
"$Header: /usr/lib/lisp/syntax.l,v 1.1 83/01/29 18:40:24 jkf Exp $")
;;
;; syntax.l -[Sat Jan 29 18:28:58 1983 by jkf]-
;;
;; contains the user callable setsyntax function
;;
;--- setsyntax :: new version of setsyntax
; this version allows symbolic syntax codes.
;
(declare
(special syntax:symbolic-to-old-fixnum ;; for upward compatibility
; use this to map from old
; fixnums to symbolic names
syntax:symbolic-bits-to-fixnum ;; bit definitions of symbolic
;bits. see h/chars.h
syntax:code-to-bits ;; used at runtime to
; interpret symbolic names
readtable ;; current readtable
))
(def setsyntax
(lexpr (n)
(cond ((not (or (equal n 2) (equal n 3)))
(error "setsyntax: 2 or 3 args required, not " n)))
; determine the correct code
(prog (given ch number)
(setq given (arg 2)
ch (arg 1))
(cond ((and (not (numberp ch))
(not (symbolp ch)))
(error "setsyntax: first arg must be a number or symbol: "
ch)))
(cond ((numberp given)
; using the old fixnum values (we suppose)
(cond ((setq number
(rassq given syntax:symbolic-to-old-fixnum))
(setq given (car number))) ; use symbolic name
(t (error "setsyntax: fixnum code is not defined: "
given)))))
(cond ((symbolp given)
; convert from common names to our symbolic names
(cond ((eq 'macro given)
(setq given 'vmacro))
((eq 'splicing given)
(setq given 'vsplicing-macro)))
; now see if the symbolic name is defined
(cond ((setq number (assq given syntax:code-to-bits))
(setq number (cdr number)))
(t (error "setsyntax: unknown symbolic code: "
given))))
(t (error "setsyntax: second arg not symbol or fixnum: "
given)))
; now call the low level code to set the value.
(int:setsyntax (arg 1) number) ;;; change to *
; the final argument is placed on the property list of the
; first argument, with the indicator being the current readtable,
; thus you can have more than one macro function for each
; character for each readtable.
(cond ((equal n 3)
(cond ((numberp ch) (setq ch (ascii ch)))) ; need symbol
(putprop ch (arg 3) readtable))))
t))
(def getsyntax
(lambda (ch)
(let ((res (int:getsyntax ch)) ; this will be modified too
(symb))
(cond ((setq symb (rassq res syntax:code-to-bits))
(car symb))
(t (error "getsyntax: no symbolic code corresponds to: "
res))))))
;--- add-syntax-class : add a new symbolic syntax class
; name is the name which we will use to refer to it.
; bits are a list of symbolic bit names for it.
; modifies global variable: syntax:code-to-bits
;
(def add-syntax-class
(lambda (name bits)
(cond ((not (symbolp name))
(error "add-syntax-class: illegal name: " name)))
(cond ((not (dtpr bits))
(error "add-syntax-class: illegal bits: " bits)))
(do ((xx bits (cdr xx))
(this 0)
(num 0))
((null xx)
(cond ((setq this (assq name syntax:code-to-bits))
(rplacd this num)) ; replace old value
(t (setq syntax:code-to-bits (cons (cons name num)
syntax:code-to-bits)))))
(cond ((setq this (assq (car xx) syntax:symbolic-bits-to-fixnum))
;(format t "num:~d, oth:~a, comb:~d~%"
; num (cdr this) (apply 'boole `(7 ,num ,(cdr this))))
(setq num (boole 7 num (cdr this)))
;(format t "res: ~d~%" num)
) ; logical or
(t (error "illegal syntax code " (car xx)))))
name))
(setq syntax:symbolic-to-old-fixnum
'((vnumber . 0) (vsign . 1) (vcharacter . 2)
(vsingle-character-symbol . 66.)
(vleft-paren . 195.) (vright-paren . 196.)
(vperiod . 133.)
(vleft-bracket . 198.) (vright-bracket . 199.) (veof . 200.)
(vsingle-quote . 201.) (vsymbol-delimiter . 138.)
(vstring-delimiter . 137.)
(villegal . 203.) (vseparator . 204.)
(vsplicing-macro . 205.) (vmacro . 206.)
(vescape . 143.))
syntax:symbolic-bits-to-fixnum
'(; character classes
(cnumber . 0) (csign . 1) (ccharacter . 2)
(cleft-paren . 3)
(cright-paren . 4) (cperiod . 5) (cleft-bracket . 6)
(cright-bracket . 7)
(csingle-quote . 9.) (csymbol-delimiter . 10.) (cillegal . 11.)
(cseparator . 12.) (csplicing-macro . 13.)
(cmacro . 14.) (cescape . 15.) (csingle-character-symbol . 16.)
(cstring-delimiter . 17.)
(csingle-macro . 18.) (csingle-splicing-macro . 19.)
(cinfix-macro . 20.)
(csingle-infix-macro . 21.)
; escape bits
(escape-when-unique . 64.)
(escape-when-first . 128.)
(escape-always . 192.)
; separator
(separator . 32.))
syntax:code-to-bits nil)
(add-syntax-class 'vnumber '(cnumber))
(add-syntax-class 'vsign '(csign))
(add-syntax-class 'vcharacter '(ccharacter))
(add-syntax-class 'vleft-paren '(cleft-paren escape-always separator))
(add-syntax-class 'vright-paren '(cright-paren escape-always separator))
(add-syntax-class 'vperiod '(cperiod escape-when-unique))
(add-syntax-class 'vleft-bracket '(cleft-bracket escape-always separator))
(add-syntax-class 'vright-bracket '(cright-bracket escape-always separator))
(add-syntax-class 'vsingle-quote '(csingle-quote escape-always separator))
(add-syntax-class 'vsymbol-delimiter '(csymbol-delimiter escape-always))
(add-syntax-class 'villegal '(cillegal escape-always separator))
(add-syntax-class 'vseparator '(cseparator escape-always separator))
(add-syntax-class 'vsplicing-macro '(csplicing-macro escape-always separator))
(add-syntax-class 'vmacro '(cmacro escape-always separator))
(add-syntax-class 'vescape '(cescape escape-always))
(add-syntax-class 'vsingle-character-symbol
'(csingle-character-symbol separator))
(add-syntax-class 'vstring-delimiter '(cstring-delimiter escape-always))
(add-syntax-class 'vsingle-macro '(csingle-macro escape-when-unique))
(add-syntax-class 'vsingle-splicing-macro
'(csingle-splicing-macro escape-when-unique))
(add-syntax-class 'vinfix-macro '(cinfix-macro escape-always separator))
(add-syntax-class 'vsingle-infix-macro
'(csingle-infix-macro escape-when-unique))