;;; Syntax1.scheme
;;; Copyright
Ó 1988, 1989, 1991 by Xerox Corporation. All rights reserved.
;;; Last changed by Pavel on March 14, 1989 4:29:47 pm PST
;;; Michael Plass, January 21, 1989 0:05:43 am PST
;;; R3RS Primitive Expressions
(extend-syntax (lambda)
;; lambda with internal defines
( (lambda args body more-body ...)
(with (((new-body ...) (handle-internal-definitions '(body more-body ...))))
(#!lambda args new-body ...))))
(extend-syntax (define)
( (define (fn . args) body more-body ...)
(define fn (lambda args body more-body ...)))
( (define name expression)
(#!define name expression)))
(extend-syntax (begin)
( (begin x) ;; Tiny optimization for the singleton case
x)
( (begin x ...)
(#!begin x ...)))
(extend-syntax (if)
( (if pred cons alt)
(#!if pred cons alt))
( (if pred cons)
(#!if pred cons (#!begin))))
;;; R3RS Derived Expressions
;;; Quasiquote gets a file of its own
;;; Binding Forms
(define essential-let
;; Named-let not allowed in this version
(make-syntax
(lambda (bindings . body)
(let ((variables (map car bindings))
(expressions (map cadr bindings)))
`((lambda ,variables ,@body)
,expressions)))))
(extend-syntax (let)
( (let ((var val) ...) body more-body ...)
((lambda (var ...)
body more-body ...)
val ...))
( (let name ((var val) ...) body more-body ...)
((letrec ((name (lambda (var ...) body more-body ...)))
name)
val ...)))
(extend-syntax (let*)
( (let* () body more-body ...)
(let () body more-body ...))
( (let* ((var val) more ...) body more-body ...)
(let ((var val))
(let* (more ...)
body more-body ...))))
(define essential-letrec
;; This one doesn't allow definitions in the body.
(make-syntax
(lambda (binding-list . body)
(let ((new-bindings (map (lambda (x)
`(,(car x) #f))
binding-list))
(new-body (append (map (lambda (x)
`(set! ,(car x) ,(cadr x)))
binding-list)
body)))
`(let ,new-bindings ,@new-body)))))
(extend-syntax (letrec)
( (letrec ((var val) ...) body more-body ...)
(with (((new-body ...) (handle-internal-definitions '(body more-body ...))))
(let ((var #f) ...)
(set! var val) ...
new-body ...))))
(define (handle-internal-definitions whole-body)
"Helper for expanding internal definitions"
"WHOLE-BODY is a list in the form
[doc-string] definition* expression expression*
Return a list in the form
[doc-string] (letrec bindings expression expression*)
if there were any definitions or
[doc-string] expression expression*
if not."
(define (expand* form)
(let ((xform (expand-once form)))
(if (eq? form xform)
form
(expand* xform))))
(define (inner body defns)
(cond
((null? body)
(error 'handle-internal-definitions whole-body "Empty body"))
((and (pair? (car body))
(memq (caar body) '(define #!define)))
(inner (cdr body)
(cons (expand* (car body))
defns)))
((and (pair? (car body))
(memq (caar body) '(begin #!begin)))
(inner (append (cdar body) (cdr body)) defns))
((null? defns)
body)
(else
`((letrec ,(map cdr (reverse defns))
,@body)))))
(if (and (string? (car whole-body))
(not (null? (cdr whole-body))))
(cons (car whole-body)
(inner (cdr whole-body) '()))
(inner whole-body '())))
;;; Conditionals
(extend-syntax (and)
This expander commits a slight deviation from R
3R in that it returns #f instead of the last false value; it does avoid the need for a lambda binding, though.
((and) #t)
((and x) x)
((and x y ...)
(if x
(and y ...)
#f)))
(extend-syntax (or)
((or) #f)
((or x) x)
((or x y ...)
(let ((first x)
(thunk (lambda () (or y ...))))
(if first
first
(thunk)))))
(extend-syntax (cond else =>)
( (cond)
(begin)) ; To get an unspecified value
( (cond (else expr1 expr2 ...))
(begin expr1 expr2 ...))
( (cond (test) more ...)
(or test
(cond more ...)))
( (cond (test => recipient) more ...)
(let ((test-result test)
(recipient-thunk (lambda () recipient))
(cond-thunk (lambda () (cond more ...))))
(if test-result
((recipient-thunk) test-result)
(cond-thunk))))
( (cond (test expr ...) more ...)
(if test
(begin expr ...)
(cond more ...))))
(extend-syntax (case else)
( (case expr clause1 clause2 ...)
(with ((var (gensym))
((clauses else-clause) (parse-case-clauses '(clause1 clause2 ...))))
(with (((((key ...) expr1 expr2 ...) ...) 'clauses)
((else else1 else2 ...) 'else-clause))
(let ((var expr))
(cond
((memv var '(key ...)) expr1 expr2 ...)
...
(else else1 else2 ...)))))))
(define (parse-case-clauses clauses)
"Helper routine for case syntax; Return a list of two elements, the normal clauses and the else clause"
(if (eq? (caar (last-pair clauses)) 'else)
(list (reverse (cdr (reverse clauses)))
(car (last-pair clauses)))
(list clauses
'(else (#!begin))))) ; For an unspecified value
;;; Iteration
(extend-syntax (do)
( (do ((var init step) ...)
(test result ...)
body ...)
(with ((loop (gensym)))
(let loop ((var init) ...)
(if test
(begin result ...)
(begin body ... (loop step ...))))))
( (do ((stuff ...) ...)
(test result ...)
body ...)
(every (lambda (binding) (<= 2 (length binding) 3))
'((stuff ...) ...))
(with ((new-bindings (map (lambda (binding)
(if (null? (cddr binding))
`(,(car binding) ,(cadr binding)
,(car binding))
binding))
'((stuff ...) ...))))
(do new-bindings
(test result ...)
body ...))))
;;; Delayed Evaluation
(extend-syntax (delay)
( (delay expr)
(let ((it (lambda () expr))
(needs-running? #t))
(lambda ()
"A promise"
(if needs-running?
(begin (set! it (it)) (set! needs-running? #f)))
it))))
(extend-syntax (cons-stream)
( (cons-stream hd tl)
(cons hd (delay tl))))