[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Fyi.
> For your purposes -- assuming you still really really want to stick
> with a pure s-expression interpreter --
> Yes I do. It is small and fast and it is not really pure (it modifies
> Scheme expressions as it evals).
I think it is not reasonable to expect R5RS be designed such that you
will not have to pay a price for your choices.
> ... I think one of the
> attributes that shows a language has expressive power is that it can
> be implemented in various ways.
There is always a cost, depending on which one of those various ways
you choose. For example, in PSI, I chose another one of those ways,
and silly me, I pay for it. For your amusement and giggle, I include
a part of the startup code for PSI...
I think this hoopla over macros is much ado about nothing.
oz
---
;; ****** standard psi library ******
(define *unspecified* '())
(set! *unspecified* (set! *unspecified* '*unspecified*))
(define abort '())
(call/cc (lambda (k) (set! abort k)))
(macro (and . exprs)
(if (null? exprs)
#t
(if (null? (cdr exprs))
(car exprs)
`(if ,(car exprs) (and ,@(cdr exprs)) #f))))
; not in standard, but used for bootstrapping rest of syntax
(macro (rec name expr)
`((lambda (,name) (set! ,name ,expr) ,name) '()))
; if we have list-transpose, we can define full R4RS for-each and map
; right now.
(if (top-level-bound? 'list-transpose)
(begin
(define (safe-list-transpose . args)
(define oeh (error-handler (lambda args (error-done) #f)))
(define ret '())
(set! ret (apply list-transpose args))
(error-handler oeh)
ret)
(define (for-each f . l)
(if (= 1 (length l))
((rec loop
(lambda (x)
(if (not (null? x))
(begin
(f (car x))
(loop (cdr x))))))
(car l))
((rec loop
(lambda (x)
(if (not (null? x))
(begin
(apply f (car x))
(loop (cdr x))))))
((lambda (tl) (if tl tl (do-error 'invargs "psi" "for-each" l)))
(safe-list-transpose l)))))
(define (map f . l)
(define ret '())
(if (= 1 (length l))
((rec loop
(lambda (x)
(if (not (null? x))
(begin
(set! ret (cons (f (car x)) ret))
(loop (cdr x))))))
(car l))
((rec loop
(lambda (x)
(if (not (null? x))
(begin
(set! ret (cons (apply f (car x)) ret))
(loop (cdr x))))))
((lambda (tl) (if tl tl (do-error 'invargs "psi" "map" l)))
(safe-list-transpose l))))
(reverse ret))
)
(begin
; initial version that doesn't handle multiple lists.
; used for bootstrapping rest of syntax.
(define (map proc ls)
((rec loop
(lambda (ls)
(if (null? ls)
'()
(cons (proc (car ls)) (loop (cdr ls))))))
ls))))
(define (*check-bindings-syntax* name bindings body)
(define howfix "expected: (ident expr)")
(define len '())
(if (null? body)
(list 'lessargs "psi" name body "body expected after bindings")
(begin
; if named let, skip past the name
(if (and (equal? name "let")
(symbol? bindings))
(begin
(set! bindings (car body))
(set! body (cdr body))))
(if (not (list? bindings))
(list 'invargs "psi" name bindings "bindings expected")
; check that each binding is of the form (symbol expr)
(call/cc
(lambda (return)
((rec loop
(lambda (bindings)
(define binding '())
(if (pair? bindings)
(begin
(set! binding (car bindings))
(set! len (if (pair? binding)
(length binding)
0))
(if (> len 2)
(return (list 'moreargs "psi" name binding howfix)))
(if (< len 2)
(return (list 'lessargs "psi" name binding howfix)))
(if (not (symbol? (car binding)))
(return (list 'invargs "psi" name binding howfix)))
(loop (cdr bindings)))
)))
bindings)
#f))))))
(macro (letrec bindings . body)
((lambda (err) (if err (apply do-error err)))
(*check-bindings-syntax* "letrec" bindings body))
((lambda (varsyms tmpsyms)
`((lambda ,varsyms
((lambda ,tmpsyms
,@((rec loop (lambda (var sym setlist)
(if (not (null? sym))
(loop (cdr var)
(cdr sym)
(cons `(set! ,(car var) ,(car sym))
setlist))
setlist)))
varsyms tmpsyms '())
((lambda () ,@body)))
,@(map (lambda (binding)
(cadr binding))
bindings)))
,@(make-list (length bindings) '*unspecified*)))
(map (lambda (binding) (car binding)) bindings)
(map (lambda x (gensym)) bindings)))
(macro (let bindings . body)
((lambda (err) (if err (apply do-error err)))
(*check-bindings-syntax* "let" bindings body))
(if (symbol? bindings)
`(letrec ((,bindings
(lambda ,(map car (car body)) ,@(cdr body))))
(,bindings ,@(map cadr (car body))))
`((lambda ,(map car bindings) ,@body) ,@(map cadr bindings))))
(macro (let* bindings . body)
((lambda (err) (if err (apply do-error err)))
(*check-bindings-syntax* "let*" bindings body))
(if (null? bindings)
`(let () ,@body)
`(let ,(list (car bindings))
(let* ,(cdr bindings) ,@body))))
(macro (or . exprs)
(if (null? exprs)
#f
(if (null? (cdr exprs))
(car exprs)
(let ((a (gensym)))
`((lambda (,a)
(if ,a ,a (or ,@(cdr exprs))))
,(car exprs))))))
(macro (delay expr)
`(let ((done #f)
(result #f)
(promise (lambda () ,expr)))
(lambda ()
(if (not done)
(begin
(set! done #t)
(set! result (promise))))
result)))
(define (force promise)
(promise))
(macro (call-with-error-handler handler action)
`(let ((old-error-handler (error-handler)))
(if (not (procedure? ,handler))
(do-error 'invargs "psi" "call-with-error-handler" ,handler
"expecting a procedure"))
(error-handler ,handler)
(let ((retval ,action))
(error-handler old-error-handler)
retval)))
; four levels of c????r are required by the standard...
(if (not (top-level-bound? 'caaar))
(begin
(define (caaar x) (car (caar x)))
(define (caadr x) (car (cadr x)))
(define (cadar x) (car (cdar x)))
(define (caddr x) (car (cddr x)))
(define (cdaar x) (cdr (caar x)))
(define (cdadr x) (cdr (cadr x)))
(define (cddar x) (cdr (cdar x)))
(define (cdddr x) (cdr (cddr x)))
(define (caaaar x) (caar (caar x)))
(define (caaadr x) (caar (cadr x)))
(define (caadar x) (caar (cdar x)))
(define (caaddr x) (caar (cddr x)))
(define (cadaar x) (cadr (caar x)))
(define (cadadr x) (cadr (cadr x)))
(define (caddar x) (cadr (cdar x)))
(define (cadddr x) (cadr (cddr x)))
(define (cdaaar x) (cdar (caar x)))
(define (cdaadr x) (cdar (cadr x)))
(define (cdadar x) (cdar (cdar x)))
(define (cdaddr x) (cdar (cddr x)))
(define (cddaar x) (cddr (caar x)))
(define (cddadr x) (cddr (cadr x)))
(define (cdddar x) (cddr (cdar x)))
(define (cddddr x) (cddr (cddr x)))))
(define (call-with-input-file filename proc)
(if (not (string? filename))
(do-error 'invargs "psi" "call-with-input-file" filename "string expected"))
(if (not (procedure? proc))
(do-error 'invargs "psi" "call-with-input-file" proc "procedure expected"))
(let ((p (call-with-error-handler
(lambda args
(set-car! (cddr args) "call-with-input-file")
(error-handler old-error-handler)
(apply old-error-handler args))
(open-input-file filename))))
(let ((v (proc p)))
(close-input-port p)
v)))
(define (call-with-output-file filename proc)
(if (not (string? filename))
(do-error 'invargs "psi" "call-with-output-file" filename "string expected"))
(if (not (procedure? proc))
(do-error 'invargs "psi" "call-with-output-file" proc "procedure expected"))
(let ((p (call-with-error-handler
(lambda args
(set-car! (cddr args) "call-with-output-file")
(error-handler old-error-handler)
(apply old-error-handler args))
(open-output-file filename))))
(let ((v (proc p)))
(close-output-port p)
v)))
(if (not (top-level-bound? 'reverse))
(define (reverse lst) (reverse! (append lst '()))))
;; this cond expands the first *max-short-cond-length* clauses into
;; nested ifs. Any clauses after that will be handled by a call/cc, where
;; the ifs are sequential. This is done to avoid excessive recursion by
;; the internal psi compiler itself which can break on DOS.
(define *max-short-cond-length* 16) ;; for MSDOS -- reduces deep recursion in C
(define (general-cond name . clauses)
(let* ((cond/long
(lambda (clauses)
(let* ((k (gensym))
(default '*unspecified*)
(cond/long-test-only
(lambda (test k)
(let ((test-name (gensym)))
`(let ((,test-name ,test))
(if ,test-name (,k ,test-name))))))
(cond/long-=>
(lambda (test exprs k)
(let ((test-name (gensym))
(proc (cadr exprs)))
`(let ((,test-name ,test))
(if ,test-name (,k (,proc ,test-name)))))))
(cond/long-normal
(lambda (test exprs k)
(if (null? (cdr exprs))
`(if ,test (,k ,(car exprs)))
`(if ,test (,k (begin ,@exprs))))))
(exec-list
(let loop ((elist '())
(clauses clauses))
(if (null? clauses)
(reverse! elist)
(let ((test (caar clauses))
(exprs (cdar clauses)))
(if (eq? test 'else)
(if (null? exprs)
(do-error 'lessargs "psi" name (car clauses) "`else' clause has no body")
(if (null? (cdr clauses))
(begin
(set! default (car exprs))
(reverse! elist))
(do-error 'moreargs "psi" name (cdr clauses) "`else' clause not at end")))
(if (null? exprs)
(loop (cons (cond/long-test-only test k) elist)
(cdr clauses))
(if (and (eq? (car exprs) '=>)
(not (null? (cdr exprs))))
(if (pair? (cddr exprs))
(do-error 'wrongnargs "psi" name exprs "`=>' not followed by single expr")
(loop (cons (cond/long-=> test exprs k)
elist)
(cdr clauses)))
(loop (cons (cond/long-normal test exprs k)
elist)
(cdr clauses))))))))))
`(call/cc (lambda (,k) ,@exec-list ,default)))))
(cond/short
(lambda (clauses)
(let loop ((pairs clauses)
(count *max-short-cond-length*))
(if (null? pairs)
'*unspecified*
(if (not (positive? count))
(cond/long pairs)
(let ((pair (car pairs))
(len (length (car pairs))))
(if (zero? len)
(do-error 'invargs "psi" name pairs)
(let ((test (if (eq? (car pair) 'else)
(if (null? (cdr pairs))
'#t
(do-error 'moreargs "psi" name pair "`else' clause not at end"))
(car pair))))
(if (= len 2)
`(if ,test ,(cadr pair) ,(loop (cdr pairs)
(1- count)))
(if (= len 1)
`(or ,test
,(loop (cdr pairs)
(1- count)))
(if (eq? (cadr pair) '=>)
(if (null? (cdddr pair))
(let ((testvar (gensym)))
`(let ((,testvar ,test))
(if ,testvar
(,(caddr pair) ,testvar)
,(loop (cdr pairs)
(1- count)))))
(do-error 'wrongnargs "psi" name (cdr pair) "`=>' not followed by single expr"))
`(if ,test
,(cons 'begin (cdr pair))
,(loop (cdr pairs)
(1- count)))))))))))))))
(if (null? clauses)
(do-error 'lessargs "psi" name clauses "No clauses"))
(if (not (let loop ((clauses clauses))
(if (null? clauses)
#t
(if (and (pair? (car clauses)) (list? (car clauses)))
(loop (cdr clauses))
#f))))
(do-error 'invargs "psi" name clauses "Not all clauses are non-null lists"))
(cond/short clauses)))
(macro (cond . clauses)
(apply general-cond "cond" clauses))
(macro (case . args)
`(let ((key ,(car args)))
,(apply general-cond "case"
(map (lambda (clause)
(if (pair? clause)
(cons
(if (eq? (car clause) 'else)
'else
(begin
(if (pair? (car clause))
`(memv key (quote ,(car clause)))
(do-error 'invargs "psi" "case" clause "Expecting: ((key ...) expression ...)"))))
(cdr clause))
clause))
(cdr args)))))
(macro (case-ci . args)
`(let ((key ,(car args)))
,(apply general-cond "case-ci"
(map (lambda (clause)
(if (pair? clause)
(cons
(if (eq? (car clause) 'else)
'else
(begin
(if (pair? (car clause))
`(memv-ci key (quote ,(car clause)))
(do-error 'invargs "psi" "case-ci" clause "Expecting: ((key ...) expression ...)"))))
(cdr clause))
clause))
(cdr args)))))
(if (not (top-level-bound? 'for-each))
(define (for-each proc . ls)
((rec loop
(lambda (ls)
(if (null? ls)
*unspecified*
(begin
(apply proc (car ls))
(loop (cdr ls))))))
(apply map list ls))))
(macro (do . args)
(let ((loop (gensym)))
`(letrec ((,loop
(lambda ,(map (lambda (n) (car n)) (car args))
(if ,(caadr args)
,(if (null? (cdadr args))
`*unspecified*
`(begin
,@(cdadr args)))
(begin
,@(cddr args)
(,loop
,@(map (lambda (n)
(if (pair? (cddr n))
(caddr n)
(car n)))
(car args))))))))
(,loop ,@(map (lambda (n) (cadr n)) (car args))))))
(define (reset) (abort *unspecified*))
;;; etc etc