![[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] / 42BSD / ucb / lisp / lisplib|
Return to charmac.l CVS log | Up to [CSRG BSD Unix] / 42BSD / 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.