[unix-history] / usr / src / pgrm / lisp / lisplib / charmac.l

;;
;; charmac.l				-[Sat Jan 29 18:13:40 1983 by jkf]-
;;
;; character macros
;; this contains the definition of the backquote and sharpsign
;; character macros.  [the backquote macro also defines the comma macro]
;;

(setq rcs-charmac-
   "$Header: /usr/lib/lisp/charmac.l,v 1.1 83/01/29 18:33:29 jkf Exp $")


(declare (macros t))

(setq **backquote** 1)

(declare (special **backquote**  Backquote-comma Backquote-comma-at
		  Backquote-comma-dot))

(setq Backquote-comma (gensym)
   Backquote-comma-at (gensym)
   Backquote-comma-dot (gensym))

(def back-quote-ch-macro 
  (lambda nil 
	  (back=quotify  ((lambda (**backquote**) (read)) 
			  (1+ **backquote**)))))

(def back-quote-comma-macro
 (lambda nil
  ((lambda (**backquote**)
	   (cond ((zerop **backquote**)
		  (error "comma not inside a backquote."))
		 ((eq (tyipeek) 64)
		  (tyi)
		  (cons Backquote-comma-at (read)))
		 ((eq (tyipeek) 46)
		  (tyi)
		  (cons Backquote-comma-dot (read)))
		 (t (cons Backquote-comma (read)))))
   (1- **backquote**))))

(def back=quotify 
  (lambda (x)
	  ((lambda (a d aa ad dqp)
		   (cond ((atom x) (list 'quote x))
			 ((eq (car x) Backquote-comma) (cdr x))
			 ((or (atom (car x))
			      (not (or (eq (caar x) Backquote-comma-at)
				       (eq (caar x) Backquote-comma-dot))))
			  (setq a (back=quotify (car x)) d (back=quotify (cdr x))
				ad (atom d) aa (atom a)
				dqp (and (not ad) (eq (car d) 'quote)))
			  (cond ((and dqp (not (atom a)) (eq (car a) 'quote))
				 (list 'quote (cons (cadr a) (cadr d))))
				((and dqp (null (cadr d)))
				 (list 'list a))
				((and (not ad) (eq (car d) 'list))
				 (cons 'list (cons a (cdr d))))
				(t (list 'cons a d))))
			 ((eq (caar x) Backquote-comma-at)
			  (list 'append (cdar x) (back=quotify (cdr x))))
			 ((eq (caar x) Backquote-comma-dot)
			  (list 'nconc (cdar x)(back=quotify (cdr x))))
			 ))
	   nil nil nil nil nil)))


(setsyntax '\` 'macro 'back-quote-ch-macro)
(setsyntax '\, 'macro 'back-quote-comma-macro)


;------- sharpsign macro, used for conditional assembly

;#O <SEXP> or #o <SEXP> reads sexp with ibase bound to 8.
;#+<FEATURE> <SEXP> makes <SEXP> exist if (STATUS FEATURE <FEATURE>) is T
;#-<FEATURE> <SEXP> makes <SEXP> exist if (STATUS FEATURE <FEATURE>) is NIL
;#+(OR F1 F2 ...) <SEXP> makes <SEXP> exist of any one of F1,F2,... are in
;			 the (STATUS FEATURES) list.
;#+(AND F1 F2 ...) works similarly except all must be present in the list.
;#+(NOT <FEATURE>) is the same as #-<FEATURE>.
;#/CHAR returns the numerical character code of CHAR.
;#\SYMBOL gets the numerical character code of non-printing characters.
;#' is to FUNCTION as ' is to QUOTE.
;#.<SEXP> evaluates <SEXP> at read time and leaves the result.
;#,<SEXP> evaluates <SEXP> at load time.  Here it is the same as "#.".
;#t returns t, this means something in NIL, I am not sure what.


(declare (special sharpm-function-names franz-symbolic-character-names))
(setq sharpm-function-names nil)

(def new-sharp-sign-macro
   (lambda ()
      ((lambda (char entry)
	  (cond ((setq entry (assq char sharpm-function-names))
		 (funcall (cdr entry) char))
		(t (error "Unknown character after #:" (ascii char)))))
       (tyi) nil)))

(setsyntax '\# 'splicing 'new-sharp-sign-macro)

;--- defsharp  ::  define a sharp sign handler
; form is (defsharp key arglist body ...)
; where key is a number or a list of numbers (fixnum equivalents of chars)
; arglist is a list of one argument, which will be bound to the fixnum
; representation of the character typed.
; body is the function to be executed when #key is seen.  it should return
; either nil or (list x) where x is what will be spliced in.
;
(def defsharp
   (macro (arg)    ; arg is (defsharp number-or-list arglist function-body)
	  (prog (name)
	     (setq name (concat "Sharpm" (cond ((dtpr (cadr arg)) (caadr arg))
					       (t (cadr arg)))
				(gensym)))
	     (cond ((dtpr (cadr arg))
		    (return `(progn 'compile
				    ,@(mapcar
					 '(lambda (x)
					     (defsharp-expand x name))
					 (cadr arg))
				    (defun ,name ,(caddr arg) ,@(cdddr arg)))))
		   (t (return `(progn 'compile
				      ,(defsharp-expand (cadr arg) name)
				      (defun ,name ,(caddr arg) ,@(cdddr arg)))))))))

(eval-when (compile load eval)
   (defun defsharp-expand (code name)
	  (cond ((symbolp code) (setq code (car (aexploden code)))))
	  `((lambda (current)
	       (cond ((setq current (assq ,code sharpm-function-names))
		      (rplacd current ',name))
		     (t (setq sharpm-function-names
			      (cons '(,code . ,name)
				    sharpm-function-names)))))
	    nil)))


;; standard sharp sign functions:
(declare (special ibase))

(defsharp (o O) (x) ((lambda (ibase) (list (read))) 8.))  ;#o #O
(defsharp (x X) (x) (do ((res 0)			  ;#x #X (hex)
			 (this (tyi) (tyi))
			 (firstch t nil)
			 (factor 1))
			(nil)
			(cond ((not (or (> this 57.)	; #/0 <= this <= #/9
					(< this 48.)))
			       (setq res (+ (* res 16.) (- this 48.))))
			      ((not (or (> this 102.)   ; #/a <= this <= #/f
					(< this  97.)))
			       (setq res (+ (* res 16.) (- this (- 97 10)))))
			      ((not (or (> this 70.)
					(< this 65.)))
			       (setq res (+ (* res 16.) (- this (- 65 10)))))
			      ((and firstch (eq this 43.)))		; #/+
			      ((and firstch (eq this 45.))		; #/-
			       (setq factor (* -1 factor)))
			      (t (untyi this)
				 (return (list (* factor res)))))))
			    
			      
(defsharp + (x) ((lambda (frob)				; #+
		      (cond ((not (feature-present frob)) (read)))
		      nil)
		   (read)))
(defsharp - (x) ((lambda (frob)				; #-
		      (cond ((feature-present frob) (read)))
		      nil)
		   (read)))
(defsharp / (x) (list (tyi)))				;#/  fixum equiv
(defsharp ^ (x) (list (boole 1 31. (tyi))))		;#^  cntrl next char
(defsharp \' (x) (list (list 'function (read))))	;#'  function
(defsharp (\, \.) (x) (list (eval (read))))		;#, or #.
(defsharp \\ (x) ((lambda (frob char)			;#\
		      (setq char
			    (cdr (assq frob franz-symbolic-character-names)))
		      (or char (error '|Illegal character name in #\\| frob))
		      (list char))
		   (read) nil))
(defsharp (t T) (x) (list t))			;#t (for NIL)
(defsharp (M m  Q q  F f) (char)  ;M m Q q F f
   (cond ((not (feature-present
		  (cadr (assoc char '((77. maclisp) (109. maclisp)
				      (81. lispm) (113. lispm)
				      (70. franz) (102. franz))))))
	  (read)))
   nil)
		      

(defun feature-present (feature)
       (cond ((atom feature)
	      (memq feature (status features)))	;damn fsubrs
	     ((eq (car feature) 'not)
	      (not (feature-present (cadr feature))))
	     ((eq (car feature) 'and)
	      (do ((list (cdr feature) (cdr list)))
		  ((null list) t)
		  (cond ((not (feature-present (car list)))
			 (return nil)))))
	     ((eq (car feature) 'or)
	      (do ((list (cdr feature) (cdr list)))
		  ((null list) nil)
		  (cond ((feature-present (car list))
			 (return t)))))
	     (t (error '|Unknown form after #+ or #-| feature))))

(setq franz-symbolic-character-names
      '((eof . -1)  (backspace . 8.)(bs . 8.)
        (tab . 9.) (lf . 10.) (linefeed . 10.)
	(ff . 12.) (form . 12.) (return . 13.) (cr . 13.)
	(newline . 10.) (vt . 11.)
        (esc . 27.) (alt . 27.) 
	(space . 32.) (sp . 32.)
	(dq . 34.)     ; "
	(lpar . 40.) (rpar . 41.)
	(vert . 124.)  ; |
	(rubout . 127.)
	))
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