
;;; 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"
(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)
((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))))


  d  
;;; 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
"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."
This expander commits a slight deviation from R3R in that it returns #f instead of the last false value; it does avoid the need for a lambda binding, though.
 ÊÏ  –(cedarcode) style•NewlineDelimiter
™ ™JšœÐetœ=™LJ™:J™2—J˜ ˜J˜ ˜J˜˜"˜LJ˜———J˜ ˜˜*J˜-—J˜ ˜J˜——J˜ ˜˜8J˜—J˜ ˜J˜——J˜ ˜˜J˜—J˜ ˜J˜——J˜ —˜J˜ J˜%˜J˜ ˜J˜(˜˜˜$J˜%J˜J˜————J˜ ˜˜+˜J˜—J˜
—J˜ ˜0˜7J˜—J˜——J˜ ˜˜J˜—J˜ ˜1˜˜J˜————J˜ šœ˜J˜2šœ˜šœ˜šœ$˜$šœ(˜(Jšœ!˜!šœ"˜"šœ2˜2šœ˜Jšœ˜————Jšœ#˜#————J˜ ˜˜.˜L˜J˜J˜————J˜ ˜0J˜+™!Jšœ/™/—šœ™Jšœ5™5—šœ ™ Jšœ#™#—J™˜˜!˜J˜J˜———J˜ ˜˜˜J˜=—˜J˜)˜˜J˜———˜J˜'J˜.—˜J˜—˜˜$J˜————J˜ ˜#J˜%˜J˜ —J˜———J˜ ˜J˜ ˜Jšœ/Ïuœm™J˜J˜˜˜J˜J˜———J˜ ˜J˜J˜
˜˜J˜"˜	J˜J˜————J˜ ˜˜	Jšœ&˜&—J˜ ˜ J˜—J˜ ˜˜J˜——J˜ ˜&˜˜*J˜)—˜J˜J˜———J˜ ˜"˜J˜J˜———J˜ ˜˜"˜J˜H˜3J˜*˜˜J˜'J˜J˜——————J˜ ˜$J˜g˜*˜'J˜—˜J˜3————J˜ ˜J˜ ˜˜˜J˜	—˜˜˜J˜J˜$————J˜ ˜˜J˜	—˜3J˜—˜+˜4˜:˜7˜J˜ ————˜J˜J˜—————J˜ ˜J˜ ˜˜˜J˜˜
J˜˜J˜0—J˜————J˜ ˜˜J˜———J˜ —J˜ — …—      G  