scsh-0.6/ps-compiler/prescheme/ps-syntax.scm

117 lines
3.2 KiB
Scheme
Raw Normal View History

1999-09-14 08:45:02 -04:00
; Copyright (c) 1994 by Richard Kelsey. See file COPYING.
; Redefine CASE so that it doesn't call MEMV
(define-syntax case
(lambda (e r c)
(let ((x (r 'x))
(xlet (r 'let))
(xcond (r 'cond))
(xif (r 'if))
(xeq? (r 'eq?))
(xquote (r 'quote)))
(let ((test (lambda (y)
`(,xeq? ,x (,xquote ,y)))))
`(,xlet ((,x ,(cadr e)))
(,xcond . ,(map (lambda (clause)
(if (c (car clause) 'else)
clause
`(,(let label ((xs (car clause)))
(cond ((null? xs) #f)
((null? (cdr xs))
(test (car xs)))
(else
`(,xif ,(test (car xs))
#t
,(label (cdr xs))))))
. ,(cdr clause))))
(cddr e))))))))
; RECEIVE (from big-scheme)
(define-syntax receive
(syntax-rules ()
((receive ?vars ?producer . ?body)
(call-with-values (lambda () ?producer)
(lambda ?vars . ?body)))))
(define-syntax external
(lambda (e r c)
(let ((l (length e)))
(if (and (or (= l 3) (= l 4))
(string? (cadr e)))
`(,(r 'real-external) ,(cadr e) ',(caddr e))
e))))
; DEFINE-EXTERNAL-ENUMERATION (from prescheme)
(define-syntax define-external-enumeration
(lambda (form rename compare)
(let* ((name (cadr form))
(symbol->upcase-string
(lambda (s)
(list->string (map (lambda (c)
(if (char=? c #\-)
#\_
(char-upcase c)))
(string->list (symbol->string s))))))
(constant
(lambda (sym string)
`(,(rename 'make-external-constant) ',name ',sym ,string)))
(conc (lambda things
(string->symbol (apply string-append
(map (lambda (thing)
(if (symbol? thing)
(symbol->string thing)
thing))
things)))))
(var-name
(lambda (sym)
(conc name "/" sym)))
(components
(list->vector
(map (lambda (stuff)
(if (pair? stuff)
(cons (car stuff)
(var-name (car stuff)))
(cons stuff
(var-name stuff))))
(caddr form))))
(%define (rename 'define))
(%define-syntax (rename 'define-syntax))
(%begin (rename 'begin))
(%quote (rename 'quote))
(%make-external-constant (rename 'make-external-constant))
(e-name (conc name '- 'enumeration))
(count (vector-length components)))
`(,%begin
(,%define-syntax ,name
(let ((components ',components))
(lambda (e r c)
(let ((key (cadr e)))
(cond ((c key 'enum)
(let ((which (caddr e)))
(let loop ((i 0)) ;vector-posq
(if (< i ,count)
(if (c which (car (vector-ref components i)))
(r (cdr (vector-ref components i)))
(loop (+ i 1)))
;; (syntax-error "unknown enumerand name"
;; `(,(cadr e) ,(car e) ,(caddr e)))
e))))
(else e))))))
(,%define ,(conc name '- 'count) ,count)
. ,(map (lambda (stuff)
(if (pair? stuff)
`(,%define ,(var-name (car stuff))
(,%make-external-constant ',name
',(car stuff)
,(cadr stuff)))
`(,%define ,(var-name stuff)
(,%make-external-constant ',name
',stuff
,(symbol->upcase-string stuff)))))
(caddr form)))))
(begin define define-syntax quote external make-external-constant))