Commit | Line | Data |
---|---|---|
82a4bd91 C |
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 |