![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to charmac.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib|
Return to charmac.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / lisp / lisplib |
1.1 ! root 1: ;; ! 2: ;; charmac.l -[Sat Jan 29 18:13:40 1983 by jkf]- ! 3: ;; ! 4: ;; character macros ! 5: ;; this contains the definition of the backquote and sharpsign ! 6: ;; character macros. [the backquote macro also defines the comma macro] ! 7: ;; ! 8: ! 9: (setq rcs-charmac- ! 10: "$Header: /usr/lib/lisp/charmac.l,v 1.1 83/01/29 18:33:29 jkf Exp $") ! 11: ! 12: ! 13: (declare (macros t)) ! 14: ! 15: (setq **backquote** 1) ! 16: ! 17: (declare (special **backquote** Backquote-comma Backquote-comma-at ! 18: Backquote-comma-dot)) ! 19: ! 20: (setq Backquote-comma (gensym) ! 21: Backquote-comma-at (gensym) ! 22: Backquote-comma-dot (gensym)) ! 23: ! 24: (def back-quote-ch-macro ! 25: (lambda nil ! 26: (back=quotify ((lambda (**backquote**) (read)) ! 27: (1+ **backquote**))))) ! 28: ! 29: (def back-quote-comma-macro ! 30: (lambda nil ! 31: ((lambda (**backquote**) ! 32: (cond ((zerop **backquote**) ! 33: (error "comma not inside a backquote.")) ! 34: ((eq (tyipeek) 64) ! 35: (tyi) ! 36: (cons Backquote-comma-at (read))) ! 37: ((eq (tyipeek) 46) ! 38: (tyi) ! 39: (cons Backquote-comma-dot (read))) ! 40: (t (cons Backquote-comma (read))))) ! 41: (1- **backquote**)))) ! 42: ! 43: (def back=quotify ! 44: (lambda (x) ! 45: ((lambda (a d aa ad dqp) ! 46: (cond ((atom x) (list 'quote x)) ! 47: ((eq (car x) Backquote-comma) (cdr x)) ! 48: ((or (atom (car x)) ! 49: (not (or (eq (caar x) Backquote-comma-at) ! 50: (eq (caar x) Backquote-comma-dot)))) ! 51: (setq a (back=quotify (car x)) d (back=quotify (cdr x)) ! 52: ad (atom d) aa (atom a) ! 53: dqp (and (not ad) (eq (car d) 'quote))) ! 54: (cond ((and dqp (not (atom a)) (eq (car a) 'quote)) ! 55: (list 'quote (cons (cadr a) (cadr d)))) ! 56: ((and dqp (null (cadr d))) ! 57: (list 'list a)) ! 58: ((and (not ad) (eq (car d) 'list)) ! 59: (cons 'list (cons a (cdr d)))) ! 60: (t (list 'cons a d)))) ! 61: ((eq (caar x) Backquote-comma-at) ! 62: (list 'append (cdar x) (back=quotify (cdr x)))) ! 63: ((eq (caar x) Backquote-comma-dot) ! 64: (list 'nconc (cdar x)(back=quotify (cdr x)))) ! 65: )) ! 66: nil nil nil nil nil))) ! 67: ! 68: ! 69: (setsyntax '\` 'macro 'back-quote-ch-macro) ! 70: (setsyntax '\, 'macro 'back-quote-comma-macro) ! 71: ! 72: ! 73: ;------- sharpsign macro, used for conditional assembly ! 74: ! 75: ;#O <SEXP> or #o <SEXP> reads sexp with ibase bound to 8. ! 76: ;#+<FEATURE> <SEXP> makes <SEXP> exist if (STATUS FEATURE <FEATURE>) is T ! 77: ;#-<FEATURE> <SEXP> makes <SEXP> exist if (STATUS FEATURE <FEATURE>) is NIL ! 78: ;#+(OR F1 F2 ...) <SEXP> makes <SEXP> exist of any one of F1,F2,... are in ! 79: ; the (STATUS FEATURES) list. ! 80: ;#+(AND F1 F2 ...) works similarly except all must be present in the list. ! 81: ;#+(NOT <FEATURE>) is the same as #-<FEATURE>. ! 82: ;#/CHAR returns the numerical character code of CHAR. ! 83: ;#\SYMBOL gets the numerical character code of non-printing characters. ! 84: ;#' is to FUNCTION as ' is to QUOTE. ! 85: ;#.<SEXP> evaluates <SEXP> at read time and leaves the result. ! 86: ;#,<SEXP> evaluates <SEXP> at load time. Here it is the same as "#.". ! 87: ;#t returns t, this means something in NIL, I am not sure what. ! 88: ! 89: ! 90: (declare (special sharpm-function-names franz-symbolic-character-names)) ! 91: (setq sharpm-function-names nil) ! 92: ! 93: (def new-sharp-sign-macro ! 94: (lambda () ! 95: ((lambda (char entry) ! 96: (cond ((setq entry (assq char sharpm-function-names)) ! 97: (funcall (cdr entry) char)) ! 98: (t (error "Unknown character after #:" (ascii char))))) ! 99: (tyi) nil))) ! 100: ! 101: (setsyntax '\# 'splicing 'new-sharp-sign-macro) ! 102: ! 103: ;--- defsharp :: define a sharp sign handler ! 104: ; form is (defsharp key arglist body ...) ! 105: ; where key is a number or a list of numbers (fixnum equivalents of chars) ! 106: ; arglist is a list of one argument, which will be bound to the fixnum ! 107: ; representation of the character typed. ! 108: ; body is the function to be executed when #key is seen. it should return ! 109: ; either nil or (list x) where x is what will be spliced in. ! 110: ; ! 111: (def defsharp ! 112: (macro (arg) ; arg is (defsharp number-or-list arglist function-body) ! 113: (prog (name) ! 114: (setq name (concat "Sharpm" (cond ((dtpr (cadr arg)) (caadr arg)) ! 115: (t (cadr arg))) ! 116: (gensym))) ! 117: (cond ((dtpr (cadr arg)) ! 118: (return `(progn 'compile ! 119: ,@(mapcar ! 120: '(lambda (x) ! 121: (defsharp-expand x name)) ! 122: (cadr arg)) ! 123: (defun ,name ,(caddr arg) ,@(cdddr arg))))) ! 124: (t (return `(progn 'compile ! 125: ,(defsharp-expand (cadr arg) name) ! 126: (defun ,name ,(caddr arg) ,@(cdddr arg))))))))) ! 127: ! 128: (eval-when (compile load eval) ! 129: (defun defsharp-expand (code name) ! 130: (cond ((symbolp code) (setq code (car (aexploden code))))) ! 131: `((lambda (current) ! 132: (cond ((setq current (assq ,code sharpm-function-names)) ! 133: (rplacd current ',name)) ! 134: (t (setq sharpm-function-names ! 135: (cons '(,code . ,name) ! 136: sharpm-function-names))))) ! 137: nil))) ! 138: ! 139: ! 140: ;; standard sharp sign functions: ! 141: (declare (special ibase)) ! 142: ! 143: (defsharp (o O) (x) ((lambda (ibase) (list (read))) 8.)) ;#o #O ! 144: (defsharp (x X) (x) (do ((res 0) ;#x #X (hex) ! 145: (this (tyi) (tyi)) ! 146: (firstch t nil) ! 147: (factor 1)) ! 148: (nil) ! 149: (cond ((not (or (> this 57.) ; #/0 <= this <= #/9 ! 150: (< this 48.))) ! 151: (setq res (+ (* res 16.) (- this 48.)))) ! 152: ((not (or (> this 102.) ; #/a <= this <= #/f ! 153: (< this 97.))) ! 154: (setq res (+ (* res 16.) (- this (- 97 10))))) ! 155: ((not (or (> this 70.) ! 156: (< this 65.))) ! 157: (setq res (+ (* res 16.) (- this (- 65 10))))) ! 158: ((and firstch (eq this 43.))) ; #/+ ! 159: ((and firstch (eq this 45.)) ; #/- ! 160: (setq factor (* -1 factor))) ! 161: (t (untyi this) ! 162: (return (list (* factor res))))))) ! 163: ! 164: ! 165: ! 166: (defsharp + (x) ((lambda (frob) ; #+ ! 167: (cond ((not (feature-present frob)) (read))) ! 168: nil) ! 169: (read))) ! 170: (defsharp - (x) ((lambda (frob) ; #- ! 171: (cond ((feature-present frob) (read))) ! 172: nil) ! 173: (read))) ! 174: (defsharp / (x) (list (tyi))) ;#/ fixum equiv ! 175: (defsharp ^ (x) (list (boole 1 31. (tyi)))) ;#^ cntrl next char ! 176: (defsharp \' (x) (list (list 'function (read)))) ;#' function ! 177: (defsharp (\, \.) (x) (list (eval (read)))) ;#, or #. ! 178: (defsharp \\ (x) ((lambda (frob char) ;#\ ! 179: (setq char ! 180: (cdr (assq frob franz-symbolic-character-names))) ! 181: (or char (error '|Illegal character name in #\\| frob)) ! 182: (list char)) ! 183: (read) nil)) ! 184: (defsharp (t T) (x) (list t)) ;#t (for NIL) ! 185: (defsharp (M m Q q F f) (char) ;M m Q q F f ! 186: (cond ((not (feature-present ! 187: (cadr (assoc char '((77. maclisp) (109. maclisp) ! 188: (81. lispm) (113. lispm) ! 189: (70. franz) (102. franz)))))) ! 190: (read))) ! 191: nil) ! 192: ! 193: ! 194: (defun feature-present (feature) ! 195: (cond ((atom feature) ! 196: (memq feature (status features))) ;damn fsubrs ! 197: ((eq (car feature) 'not) ! 198: (not (feature-present (cadr feature)))) ! 199: ((eq (car feature) 'and) ! 200: (do ((list (cdr feature) (cdr list))) ! 201: ((null list) t) ! 202: (cond ((not (feature-present (car list))) ! 203: (return nil))))) ! 204: ((eq (car feature) 'or) ! 205: (do ((list (cdr feature) (cdr list))) ! 206: ((null list) nil) ! 207: (cond ((feature-present (car list)) ! 208: (return t))))) ! 209: (t (error '|Unknown form after #+ or #-| feature)))) ! 210: ! 211: (setq franz-symbolic-character-names ! 212: '((eof . -1) (backspace . 8.)(bs . 8.) ! 213: (tab . 9.) (lf . 10.) (linefeed . 10.) ! 214: (ff . 12.) (form . 12.) (return . 13.) (cr . 13.) ! 215: (newline . 10.) (vt . 11.) ! 216: (esc . 27.) (alt . 27.) ! 217: (space . 32.) (sp . 32.) ! 218: (dq . 34.) ; " ! 219: (lpar . 40.) (rpar . 41.) ! 220: (vert . 124.) ; | ! 221: (rubout . 127.) ! 222: )) ! 223:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.