;; charmac.l -[Sat Jan 29 18:13:40 1983 by jkf]-
;; this contains the definition of the backquote and sharpsign
;; character macros. [the backquote macro also defines the comma macro]
"$Header: /usr/lib/lisp/charmac.l,v 1.1 83/01/29 18:33:29 jkf Exp $")
(declare (special **backquote** Backquote-comma Backquote-comma-at
(setq Backquote-comma (gensym)
Backquote-comma-at (gensym)
Backquote-comma-dot (gensym))
(back=quotify ((lambda (**backquote**) (read))
(def back-quote-comma-macro
(cond ((zerop **backquote**)
(error "comma not inside a backquote."))
(cons Backquote-comma-at (read)))
(cons Backquote-comma-dot (read)))
(t (cons Backquote-comma (read)))))
(cond ((atom x) (list 'quote x))
((eq (car x) Backquote-comma) (cdr 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))
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)))
((and (not ad) (eq (car d) 'list))
(cons 'list (cons a (cdr 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))))
(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
(cond ((setq entry (assq char sharpm-function-names))
(funcall (cdr entry) char))
(t (error "Unknown character after #:" (ascii char)))))
(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.
(macro (arg) ; arg is (defsharp number-or-list arglist function-body)
(setq name (concat "Sharpm" (cond ((dtpr (cadr arg)) (caadr arg))
(defsharp-expand x name))
(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)))))
(cond ((setq current (assq ,code sharpm-function-names))
(t (setq sharpm-function-names
sharpm-function-names)))))
;; 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)
(cond ((not (or (> this 57.) ; #/0 <= this <= #/9
(setq res (+ (* res 16.) (- this 48.))))
((not (or (> this 102.) ; #/a <= this <= #/f
(setq res (+ (* res 16.) (- this (- 97 10)))))
(setq res (+ (* res 16.) (- this (- 65 10)))))
((and firstch (eq this 43.))) ; #/+
((and firstch (eq this 45.)) ; #/-
(setq factor (* -1 factor)))
(return (list (* factor res)))))))
(defsharp + (x) ((lambda (frob) ; #+
(cond ((not (feature-present frob)) (read)))
(defsharp - (x) ((lambda (frob) ; #-
(cond ((feature-present frob) (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) ;#\
(cdr (assq frob franz-symbolic-character-names)))
(or char (error '|Illegal character name in #\\| frob))
(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)
(70. franz) (102. franz))))))
(defun feature-present (feature)
(memq feature (status features))) ;damn fsubrs
(not (feature-present (cadr feature))))
(do ((list (cdr feature) (cdr list)))
(cond ((not (feature-present (car list)))
(do ((list (cdr feature) (cdr list)))
(cond ((feature-present (car list))
(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.)
(lpar . 40.) (rpar . 41.)