Return to syntax.l CVS log

Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib

Annotation of 43BSD/ucb/lisp/lisplib/syntax.l, revision 1.1

1.1     ! root        1: (setq rcs-syntax-
        !             2:    "$Header: /usr/lib/lisp/syntax.l,v 1.1 83/01/29 18:40:24 jkf Exp $")
        !             3: 
        !             4: ;;
        !             5: ;; syntax.l                            -[Sat Jan 29 18:28:58 1983 by jkf]-
        !             6: ;;
        !             7: ;; contains the user callable setsyntax function
        !             8: ;;
        !             9: 
        !            10: 
        !            11: ;--- setsyntax :: new version of setsyntax
        !            12: ;  this version allows symbolic syntax codes.
        !            13: ;
        !            14: (declare
        !            15:    (special syntax:symbolic-to-old-fixnum ;; for upward compatibility
        !            16:                                        ; use this to map from old
        !            17:                                        ; fixnums to symbolic names
        !            18:            syntax:symbolic-bits-to-fixnum ;; bit definitions of symbolic
        !            19:                                           ;bits.  see h/chars.h
        !            20:            syntax:code-to-bits         ;; used at runtime to
        !            21:                                        ; interpret symbolic names
        !            22:            readtable                   ;; current readtable
        !            23:    ))
        !            24: 
        !            25: 
        !            26: (def setsyntax
        !            27:    (lexpr (n)
        !            28:          (cond ((not (or (equal n 2) (equal n 3)))
        !            29:                 (error "setsyntax: 2 or 3 args required, not " n)))
        !            30:          ; determine the correct code
        !            31:          (prog (given ch number)
        !            32:             (setq given (arg 2)
        !            33:                   ch    (arg 1))
        !            34:             (cond ((and (not (numberp ch))
        !            35:                         (not (symbolp ch)))
        !            36:                    (error "setsyntax: first arg must be a number or symbol: "
        !            37:                           ch)))
        !            38:             (cond ((numberp given)
        !            39:                    ; using the old fixnum values (we suppose)
        !            40:                    (cond ((setq number
        !            41:                                 (rassq given syntax:symbolic-to-old-fixnum))
        !            42:                           (setq given (car number))) ; use symbolic name
        !            43:                          (t (error "setsyntax: fixnum code is not defined: "
        !            44:                                    given)))))
        !            45:             (cond ((symbolp given)
        !            46:                    ; convert from common names to our symbolic names
        !            47:                    (cond ((eq 'macro given)
        !            48:                           (setq given 'vmacro))
        !            49:                          ((eq 'splicing given)
        !            50:                           (setq given 'vsplicing-macro)))
        !            51:                    ; now see if the symbolic name is defined
        !            52:                    (cond ((setq number (assq given syntax:code-to-bits))
        !            53:                           (setq number (cdr number)))
        !            54:                          (t (error "setsyntax: unknown symbolic code: "
        !            55:                                    given))))
        !            56:                   (t (error "setsyntax: second arg not symbol or fixnum: "
        !            57:                             given)))
        !            58:             ; now call the low level code to set the value.
        !            59:             (int:setsyntax (arg 1) number)             ;;; change to *
        !            60:             ; the final argument is placed on the property list of the
        !            61:             ; first argument, with the indicator being the current readtable,
        !            62:             ; thus you can have more than one macro function for each
        !            63:             ; character for each readtable.
        !            64:             (cond ((equal n 3)
        !            65:                    (cond ((numberp ch) (setq ch (ascii ch))))   ; need symbol
        !            66:                    (putprop ch (arg 3) readtable))))
        !            67:    t))
        !            68:             
        !            69: 
        !            70: (def getsyntax
        !            71:    (lambda (ch)
        !            72:       (let ((res (int:getsyntax ch))   ; this will be modified too
        !            73:            (symb))
        !            74:         (cond ((setq symb (rassq res syntax:code-to-bits))
        !            75:                (car symb))
        !            76:               (t (error "getsyntax: no symbolic code corresponds to: "
        !            77:                         res))))))
        !            78: 
        !            79: 
        !            80: ;--- add-syntax-class : add a new symbolic syntax class
        !            81: ; name is the name which we will use to refer to it.
        !            82: ; bits are a list of symbolic bit names for it.
        !            83: ; modifies global variable: syntax:code-to-bits
        !            84: ;
        !            85: (def add-syntax-class
        !            86:    (lambda (name bits)
        !            87:       (cond ((not (symbolp name))
        !            88:             (error "add-syntax-class: illegal name: " name)))
        !            89:       (cond ((not (dtpr bits))
        !            90:             (error "add-syntax-class: illegal bits: " bits)))
        !            91:       (do ((xx bits (cdr xx))
        !            92:           (this 0)
        !            93:           (num 0))
        !            94:          ((null xx)
        !            95:           (cond ((setq this (assq name syntax:code-to-bits))
        !            96:                  (rplacd this num))    ; replace old value
        !            97:                 (t (setq syntax:code-to-bits (cons (cons name num)
        !            98:                                                    syntax:code-to-bits)))))
        !            99:          (cond ((setq this (assq (car xx) syntax:symbolic-bits-to-fixnum))
        !           100:                 ;(format t "num:~d, oth:~a, comb:~d~%"
        !           101:                        ; num (cdr this) (apply 'boole `(7 ,num ,(cdr this))))
        !           102:                 (setq num (boole 7 num (cdr this)))
        !           103:                 ;(format t "res: ~d~%" num)
        !           104:                 )   ; logical or
        !           105:                (t (error "illegal syntax code " (car xx)))))
        !           106:       name))
        !           107: 
        !           108: (setq syntax:symbolic-to-old-fixnum
        !           109:        '((vnumber . 0) (vsign . 1) (vcharacter . 2)
        !           110:         (vsingle-character-symbol . 66.)
        !           111:         (vleft-paren . 195.) (vright-paren . 196.)
        !           112:         (vperiod . 133.)
        !           113:         (vleft-bracket . 198.) (vright-bracket . 199.) (veof . 200.)
        !           114:         (vsingle-quote . 201.) (vsymbol-delimiter . 138.)
        !           115:         (vstring-delimiter . 137.)
        !           116:         (villegal . 203.) (vseparator . 204.)
        !           117:         (vsplicing-macro . 205.) (vmacro . 206.)
        !           118:         (vescape . 143.))
        !           119:    syntax:symbolic-bits-to-fixnum 
        !           120:        '(; character classes
        !           121:           (cnumber . 0) (csign . 1) (ccharacter . 2)
        !           122:           (cleft-paren . 3)
        !           123:           (cright-paren . 4) (cperiod . 5) (cleft-bracket . 6)
        !           124:           (cright-bracket . 7)
        !           125:           (csingle-quote . 9.) (csymbol-delimiter . 10.) (cillegal . 11.)
        !           126:           (cseparator . 12.) (csplicing-macro . 13.)
        !           127:           (cmacro . 14.) (cescape . 15.) (csingle-character-symbol . 16.)
        !           128:           (cstring-delimiter . 17.)
        !           129:           (csingle-macro . 18.) (csingle-splicing-macro . 19.)
        !           130:           (cinfix-macro . 20.)
        !           131:           (csingle-infix-macro . 21.)
        !           132:          ; escape bits
        !           133:           (escape-when-unique . 64.)
        !           134:           (escape-when-first . 128.)
        !           135:           (escape-always . 192.)
        !           136:          ; separator
        !           137:           (separator . 32.))
        !           138:    syntax:code-to-bits nil)
        !           139:        
        !           140: (add-syntax-class 'vnumber     '(cnumber))
        !           141: (add-syntax-class 'vsign       '(csign))
        !           142: (add-syntax-class 'vcharacter  '(ccharacter))
        !           143: (add-syntax-class 'vleft-paren         '(cleft-paren escape-always separator))
        !           144: (add-syntax-class 'vright-paren        '(cright-paren escape-always separator))
        !           145: (add-syntax-class 'vperiod     '(cperiod escape-when-unique))
        !           146: (add-syntax-class 'vleft-bracket '(cleft-bracket escape-always separator))
        !           147: (add-syntax-class 'vright-bracket '(cright-bracket escape-always separator))
        !           148: (add-syntax-class 'vsingle-quote '(csingle-quote escape-always separator))
        !           149: (add-syntax-class 'vsymbol-delimiter   '(csymbol-delimiter escape-always))
        !           150: (add-syntax-class 'villegal    '(cillegal escape-always separator))
        !           151: (add-syntax-class 'vseparator  '(cseparator escape-always separator))
        !           152: (add-syntax-class 'vsplicing-macro '(csplicing-macro escape-always separator))
        !           153: (add-syntax-class 'vmacro      '(cmacro escape-always separator))
        !           154: (add-syntax-class 'vescape     '(cescape escape-always))
        !           155: (add-syntax-class 'vsingle-character-symbol
        !           156:                  '(csingle-character-symbol separator))
        !           157: (add-syntax-class 'vstring-delimiter   '(cstring-delimiter escape-always))
        !           158: (add-syntax-class 'vsingle-macro '(csingle-macro escape-when-unique))
        !           159: (add-syntax-class 'vsingle-splicing-macro
        !           160:                 '(csingle-splicing-macro escape-when-unique))
        !           161: (add-syntax-class 'vinfix-macro '(cinfix-macro escape-always separator))
        !           162: (add-syntax-class 'vsingle-infix-macro
        !           163:                   '(csingle-infix-macro escape-when-unique))
        !           164: 
        !           165: 

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.