248 lines
6.8 KiB
Scheme
248 lines
6.8 KiB
Scheme
;preproc.scm
|
|
;Macro preprocessor for SLaTeX
|
|
;(c) Dorai Sitaram, Rice U., 1991, 1994
|
|
|
|
;property lists
|
|
|
|
(define preproc:*properties* '())
|
|
|
|
(define preproc:get
|
|
(lambda (sym prop . default)
|
|
(let ((sym-props (assoc sym preproc:*properties*)))
|
|
(cond (sym-props
|
|
(let ((prop-val (assoc prop (cdr sym-props))))
|
|
(cond (prop-val (cdr prop-val))
|
|
((pair? default) (car default))
|
|
(else #f))))
|
|
((pair? default) (car default))
|
|
(else #f)))))
|
|
|
|
(define preproc:put
|
|
(lambda (sym prop val)
|
|
(let ((sym-props (assoc sym preproc:*properties*)))
|
|
(if sym-props
|
|
(let* ((props (cdr sym-props))
|
|
(prop-val (assoc prop props)))
|
|
(if prop-val
|
|
(set-cdr! prop-val val)
|
|
(set-cdr! sym-props
|
|
(cons (cons prop val) props))))
|
|
(set! preproc:*properties*
|
|
(cons (cons sym (list (cons prop val)))
|
|
preproc:*properties*))))))
|
|
|
|
;define-macro
|
|
|
|
(define defmacro-preproc
|
|
(lambda (kw xfmr)
|
|
(preproc:put #f kw kw)
|
|
(preproc:put kw 'defmacro-preproc xfmr)))
|
|
|
|
(define preproc:macro?
|
|
(lambda (s)
|
|
(and (symbol? s)
|
|
(preproc:get s 'defmacro-preproc))))
|
|
|
|
(define expand-macrocalls
|
|
(lambda (e)
|
|
(if (not (pair? e)) e
|
|
(let* ((a (car e)) (xfmr (preproc:macro? a)))
|
|
(if xfmr
|
|
(expand-macrocalls (apply xfmr (cdr e)))
|
|
(case a
|
|
;;something that looks like a macro call
|
|
;;within quote shouldn't be expanded
|
|
((quote) e)
|
|
;;lambda-arg can contain dotted list -- so
|
|
;;we avoid letting else-clause map across it
|
|
((lambda)
|
|
`(lambda ,(cadr e)
|
|
,@(map expand-macrocalls (cddr e))))
|
|
;;case-tags can look like macro calls -- these
|
|
;;shouldn't be expanded
|
|
((case)
|
|
`(case ,(expand-macrocalls (cadr e))
|
|
,@(map (lambda (clause)
|
|
`(,(car clause)
|
|
,@(map expand-macrocalls (cdr clause))))
|
|
(cddr e))))
|
|
;;expand-macrocalls can be mapped across the rest --
|
|
;;it isn't likely that we can have an expression
|
|
;;that looks like a macro call but isn't
|
|
(else (map expand-macrocalls e))))))))
|
|
|
|
;some macros
|
|
|
|
;package
|
|
|
|
(define make-slatex-alias
|
|
(lambda (zz)
|
|
(if (not (null? zz))
|
|
(begin
|
|
(preproc:put 'slatex (car zz) (cadr zz))
|
|
(make-slatex-alias (cddr zz))))))
|
|
|
|
(load "aliases.scm")
|
|
|
|
(define preproc:string-index
|
|
(lambda (s c)
|
|
(let ((n (string-length s)))
|
|
(let loop ((i 0))
|
|
(cond ((>= i n) #f)
|
|
((char=? (string-ref s i) c) i)
|
|
(else (loop (+ i 1))))))))
|
|
|
|
(defmacro-preproc 'in-package
|
|
(lambda (p) #f))
|
|
|
|
(defmacro-preproc 'shadow
|
|
(lambda (xx) #f))
|
|
|
|
(define *current-package* #f)
|
|
|
|
(defmacro-preproc 'eval-within
|
|
(lambda (p . ee)
|
|
(let ((ee
|
|
(let insert-qualifieds ((e ee))
|
|
(cond ((pair? e)
|
|
(set-car! e (insert-qualifieds (car e)))
|
|
(set-cdr! e (insert-qualifieds (cdr e)))
|
|
e)
|
|
((symbol? e)
|
|
(%eval-within-get-qualified-symbol p e))
|
|
(else e)))))
|
|
(case (length ee)
|
|
((0) #f)
|
|
((1) (car ee))
|
|
(else (cons 'begin ee))))))
|
|
|
|
(define %eval-within-get-qualified-symbol
|
|
(lambda (curr-p px)
|
|
(let* ((px-s (symbol->string px))
|
|
(i (%eval-within-dblcolon-index px-s)))
|
|
(cond (i (let ((p (string->symbol (substring px-s 0 i)))
|
|
(x (string->symbol (substring px-s (+ i 2)
|
|
(string-length px-s)))))
|
|
(if (eq? p curr-p) (preproc:put p x px))
|
|
px))
|
|
(else (cond ((preproc:get curr-p px))
|
|
((preproc:get #f px))
|
|
(else px)))))))
|
|
|
|
(define %eval-within-dblcolon-index
|
|
(lambda (s)
|
|
(let ((i (preproc:string-index s #\:)))
|
|
(if (or (not i)
|
|
(= i (- (string-length s) 1))) #f
|
|
(let ((i+1 (+ i 1)))
|
|
(if (char=? (string-ref s i+1) #\:)
|
|
i #f))))))
|
|
|
|
;defvar
|
|
|
|
(defmacro-preproc 'defvar
|
|
(lambda (x e)
|
|
`(define ,x ,e)))
|
|
|
|
;fluid-let
|
|
|
|
(define gentemp
|
|
(let ((n -1))
|
|
(lambda ()
|
|
;;generates an allegedly new symbol. This is a
|
|
;;gross hack since there is no standardized way
|
|
;;of getting uninterned symbols
|
|
(set! n (+ n 1))
|
|
(string->symbol (string-append "%:g" (number->string n) "%")))))
|
|
|
|
(defmacro-preproc 'fluid-let
|
|
(lambda (let-pairs . body)
|
|
(let ((x-s (map car let-pairs))
|
|
(i-s (map cadr let-pairs))
|
|
(old-x-s (map (lambda (p) (gentemp)) let-pairs)))
|
|
`(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s)
|
|
,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s)
|
|
(let ((%temp% (begin ,@body)))
|
|
,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s)
|
|
%temp%)))))
|
|
|
|
;defenum
|
|
|
|
(defmacro-preproc 'defenum
|
|
(lambda z
|
|
(let loop ((z z) (n 0) (r '()))
|
|
(if (null? z) `(begin ,@r)
|
|
(loop (cdr z) (+ n 1)
|
|
(cons `(define ,(car z) (integer->char ,n)) r))))))
|
|
|
|
;defrecord
|
|
|
|
(defmacro-preproc 'defrecord
|
|
(lambda (name . fields)
|
|
(let loop ((fields fields) (i 0) (r '()))
|
|
(if (null? fields)
|
|
`(begin (define ,name (lambda () (make-vector ,i)))
|
|
,@r)
|
|
(loop (cdr fields) (+ i 1)
|
|
(cons `(define ,(car fields) ,i) r))))))
|
|
|
|
;of
|
|
|
|
(defmacro-preproc 'of
|
|
(lambda (r i . z)
|
|
(cond ((null? z) `(vector-ref ,r ,i))
|
|
((and (eq? i '/) (= (length z) 1))
|
|
`(string-ref ,r ,(car z)))
|
|
(else `(of (vector-ref ,r ,i) ,@z)))))
|
|
|
|
;setf
|
|
|
|
(defmacro-preproc 'setf
|
|
(lambda (l r)
|
|
(if (symbol? l) `(set! ,l ,r)
|
|
(let ((a (car l)))
|
|
(if (eq? a 'list-ref)
|
|
`(set-car! (list-tail ,@(cdr l)) ,r)
|
|
`(,(cond ((eq? a 'list-ref) 'list-set!)
|
|
((eq? a 'string-ref) 'string-set!)
|
|
((eq? a 'vector-ref) 'vector-set!)
|
|
((eq? a 'of) 'the-setter-for-of)
|
|
(else
|
|
(error "(setf ~s ~s) is ill-formed." l r)))
|
|
,@(cdr l) ,r))))))
|
|
|
|
;the-setter-for-of
|
|
|
|
(defmacro-preproc 'the-setter-for-of
|
|
(lambda (r i j . z)
|
|
(cond ((null? z) `(vector-set! ,r ,i ,j))
|
|
((and (eq? i '/) (= (length z) 1))
|
|
`(string-set! ,r ,j ,(car z)))
|
|
(else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z)))))
|
|
|
|
;eval-{if,unless}
|
|
|
|
(defmacro-preproc 'eval-if
|
|
(lambda (dialects . body)
|
|
(if (memq dialect dialects)
|
|
(if (= (length body) 1) (car body)
|
|
`(begin ,@body))
|
|
`#f)))
|
|
|
|
(defmacro-preproc 'eval-unless
|
|
(lambda (dialects . body)
|
|
(if (not (memq dialect dialects))
|
|
(if (= (length body) 1) (car body)
|
|
`(begin ,@body))
|
|
`#f)))
|
|
|
|
;func{tion, all}
|
|
|
|
(defmacro-preproc 'function
|
|
(lambda (x)
|
|
`,x))
|
|
|
|
(defmacro-preproc 'funcall
|
|
(lambda (f . args)
|
|
`(,f ,@args)))
|