usr/src/usr.bin/lisp/lisplib/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))