Scheme Interpretor in Scheme...

[Yvon-Rene Blanchard]

Hey !

I'm looking for a scheme interpretor written in scheme...

Anyone could help me plz?

Thank you !

[David Rush]

"Yvon-Rene Blanchard" <rut...@hotmail.com> writes:
> I'm looking for a scheme interpretor written in scheme...
>
> Anyone could help me plz?

In fact Al* Petrofsky has just recently posted one here on c.l.s in
response to my rants about the inadequacy of R5RS eval. It works well
enough to replace eval on some of the systems I found problematic
*and* it's only 455 lines of code. It's not terribly efficient, but I
don't think that was really a design goal.

You can get it at:
http://groups.google.com/groups?hl=en&lr=&selm=87it5ipi79.fsf%40radish.petrofsky.org

david rush
--
I repeat myself when under stress. I repeat myself when under
stress. I repeat myself when under stress. I repeat myself when
under stress. I repeat myself when under stress. I repeat myself
when under stress. I repeat myself when under stress. I repeat

[Michael Sperber [Mr. Preprocessor]]

>>>>> "Yvon-Rene" == Yvon-Rene Blanchard <rut...@hotmail.com> writes:

Yvon-Rene> Hey !

Yvon-Rene> I'm looking for a scheme interpretor written in scheme...

There's a fairly complete one as part of Scheme 48, in the file
scheme/debug/run.scm.

--
Cheers =8-} Mike
Friede, Völkerverständigung und überhaupt blabla

[Alameda County Petrofsky]

David Rush <ku...@bellsouth.net> writes:

> In fact Al* Petrofsky has just recently posted one here on c.l.s in
> response to my rants about the inadequacy of R5RS eval. It works well
> enough to replace eval on some of the systems I found problematic
> *and* it's only 455 lines of code. It's not terribly efficient, but I
> don't think that was really a design goal.

Right. The design goal was to minimally implement the r5rs eval spec.

After posting it, I realized there were a few more simplifications I
could make. Here's a version in which eval is about 20% smaller.
Transformers and environments are now represented by procedures rather
than list structures. The main helper procedures in eval have been
regularized and renamed to eval-begin, eval-lambda, and
eval-syntax-rules. Let-syntax and letrec-syntax are now just synonyms
for let and letrec (this works because there is no separate
macro-expansion pass: macro uses are expanded as part of their
execution, and transformers are just specially marked procedures in
the runtime environment). I also added a simple repl.

-al

;; eiod.scm: eval-in-one-define, version 20020528.
;;
;; A minimal implementation of r5rs eval, null-environment, and
;; scheme-report-environment.

;; Copyright 2002 Al Petrofsky <a...@petrofsky.org>
;; You may redistribute and/or modify this software under the terms of
;; the GNU General Public License as published by the Free Software
;; Foundation (fsf.org); either version 2, or (at your option) any
;; later version.

;; Data Structures:

;; An environment is a procedure that takes an identifier and returns
;; a binding. A binding is either a mutable pair of an identifier and
;; its value, or, for identifiers with no non-builtin binding, it is a
;; symbol that represents the identifier's original name.

;; binding: [symbol | (identifier . [value | macro])]
;; macro: (procedure . marker)
;; identifier: [symbol | (binding . marker)]

;; A value is any arbitrary scheme value. Macros are stored in pairs
;; whose cdr is the eq?-unique marker object. The car is a procedure
;; of two arguments: a macro use and the environment of the macro use.

;; When a template containing a literal identifier is expanded, the
;; identifier is replaced with a fresh identifier, which is a new pair
;; containing the marker object and the binding of the old identifier
;; in the environment of the macro.

;; This environment and identifier model is similar to the one
;; described in the 1991 paper "Macros that Work" by Clinger and Rees.

(define eval
(let ()
(define marker (vector '*eval-marker*))
(define (mark x) (cons x marker))
(define unmark car)
(define (marked? x) (and (pair? x) (eq? marker (cdr x))))

(define (id? sexp) (or (symbol? sexp) (marked? sexp)))
(define (spair? sexp) (and (pair? sexp) (not (marked? sexp))))

(define (ids->syms sexp)
(cond ((id? sexp) (let loop ((x sexp)) (if (pair? x) (loop (car x)) x)))
((pair? sexp) (cons (ids->syms (car sexp)) (ids->syms (cdr sexp))))
((vector? sexp) (list->vector (ids->syms (vector->list sexp))))
(else sexp)))

(define (empty-env id) (if (symbol? id) id (unmark id)))
(define (env-add id val env)
(define binding (cons id val))
(lambda (i) (if (eq? id i) binding (env i))))

(define (xeval sexp env)
(let eval-in-this-env ((sexp sexp))
(cond ((id? sexp) (cdr (env sexp)))
((not (spair? sexp)) sexp)
(else
(let ((head (car sexp)) (tail (cdr sexp)))
(let ((binding (and (id? head) (env head))))
(case binding
((get-env) env)
((quote) (ids->syms (car tail)))
((begin) (eval-begin tail env))
((lambda) (eval-lambda tail env))
((set!) (set-cdr! (env (car tail))
(eval-in-this-env (cadr tail))))
((syntax-rules) (eval-syntax-rules tail env))
(else (let ((val (and binding (cdr binding))))
(if (marked? val)
(eval-in-this-env ((unmark val) sexp env))
(apply (eval-in-this-env head)
(map eval-in-this-env tail))))))))))))

(define (eval-begin tail env)
;; Don't use for-each because we must tail-call the last expression.
(do ((sexps tail (cdr sexps)))
((null? (cdr sexps)) (xeval (car sexps) env))
(xeval (car sexps) env)))

(define (eval-lambda tail env)
(lambda args
(define ienv (do ((args args (cdr args))
(vars (car tail) (cdr vars))
(env env (env-add (car vars) (car args) env)))
((not (spair? vars))
(if (null? vars) env (env-add vars args env)))))
(let loop ((ienv ienv) (defs '()) (body (cdr tail)))
(let ((first (car body)) (rest (cdr body)))
(let* ((head (and (spair? first) (car first)))
(binding (and (id? head) (ienv head))))
(case binding
((begin) (loop ienv defs (append (cdr first) rest)))
((builtin-define) (loop (env-add (cadr first) 'undefined ienv)
(cons first defs)
rest))
(else
(let ((val (and (pair? binding) (cdr binding))))
(if (marked? val)
(loop ienv defs (cons ((unmark val) first ienv) rest))
(begin
(for-each (lambda (var val) (set-cdr! (ienv var) val))
(map cadr defs)
(map (lambda (def) (xeval (caddr def) ienv))
defs))
(eval-begin body ienv)))))))))))

(define (eval-syntax-rules mac-tail mac-env)
(define literals (car mac-tail))
(define rules (cdr mac-tail))

(define (pat-literal? id) (memq id literals))
(define (not-pat-literal? id) (not (pat-literal? id)))

(define (ellipsis? x) (and (id? x) (eq? '... (mac-env x))))
(define (ellipsis-pair? x) (and (spair? x) (ellipsis? (car x))))

;; List-ids returns a list of those ids in a pattern or template
;; for which (pred? id) is true. If include-scalars is false, we
;; only include ids that are within the scope of at least one
;; ellipsis.
(define (list-ids x include-scalars pred?)
(let collect ((x x) (including include-scalars) (l '()))
(cond ((vector? x) (collect (vector->list x) including l))
((and (id? x) including (pred? x))
(cons x l))
((spair? x)
(if (ellipsis-pair? (cdr x))
(collect (car x) #t
(collect (cddr x) including l))
(collect (car x) including
(collect (cdr x) including l))))
(else l))))

;; Returns #f or an alist mapping each pattern var to a part of
;; the input. Ellipsis vars are mapped to lists of parts (or
;; lists of lists...).
(define (match-pattern pat use env)
(call-with-current-continuation
(lambda (return)
(define (fail) (return #f))
(let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '()))
(define (continue-if condition) (if condition bindings (fail)))
(cond
((id? pat)
(if (pat-literal? pat)
(continue-if (and (id? sexp) (eq? (mac-env pat)
(env sexp))))
(cons (cons pat sexp) bindings)))
((vector? pat)
(or (vector? sexp) (fail))
(match (vector->list pat) (vector->list sexp) bindings))
((not (spair? pat))
(continue-if (equal? pat sexp)))
((ellipsis-pair? (cdr pat))
(or (list? sexp) (fail))
(append (apply map list (list-ids pat #t not-pat-literal?)
(map (lambda (x)
(map cdr (match (car pat) x '())))
sexp))
bindings))
((spair? sexp)
(match (car pat) (car sexp)
(match (cdr pat) (cdr sexp) bindings)))
(else (fail)))))))

(define (expand-template pat tmpl top-bindings)
(define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?))
(define (list-ellipsis-vars subtmpl)
(list-ids subtmpl #t (lambda (id) (memq id ellipsis-vars))))
;; New-literals is an alist mapping each literal id in the
;; template to a fresh id for inserting into the output. It
;; might have duplicate entries mapping an id to two different
;; fresh ids, but that's okay because when we go to retrieve a
;; fresh id, assq will always retrieve the first one.
(define new-literals
(map (lambda (id) (cons id (mark (mac-env id))))
(list-ids tmpl #t (lambda (id) (not (assq id top-bindings))))))
(let expand ((tmpl tmpl) (bindings top-bindings))
(let expand-part ((tmpl tmpl))
(cond
((id? tmpl) (cdr (or (assq tmpl bindings)
(assq tmpl top-bindings)
(assq tmpl new-literals))))
((vector? tmpl) (list->vector (expand-part (vector->list tmpl))))
((spair? tmpl)
(if (ellipsis-pair? (cdr tmpl))
(let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
(append (apply map
(lambda vals
(expand (car tmpl)
(map cons vars-to-iterate vals)))
(map (lambda (var)
(cdr (assq var bindings)))
vars-to-iterate))
(expand-part (cddr tmpl))))
(cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
(else tmpl)))))

(mark (lambda (use env)
(let loop ((rules rules))
(define rule (car rules))
(let ((pat (car rule)) (tmpl (cadr rule)))
(define bindings (match-pattern pat use env))
(if bindings
(expand-template pat tmpl bindings)
(loop (cdr rules))))))))

;; We make a copy of the initial input to ensure that subsequent
;; mutation of it does not affect eval's result. [1]
(lambda (initial-sexp env)
(xeval (let copy ((x initial-sexp))
(cond ((string? x) (string-copy x))
((pair? x) (cons (copy (car x)) (copy (cdr x))))
((vector? x) (list->vector (copy (vector->list x))))
(else x)))
(or env empty-env)))))

(define null-environment
(let ()
(define macro-defs
'((define-syntax quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
(`,x x)
(`(,@x . y) (append x `y))
((_ `x . d) (cons 'quasiquote (quasiquote (x) d)))
((_ ,x d) (cons 'unquote (quasiquote (x) . d)))
((_ ,@x d) (cons 'unquote-splicing (quasiquote (x) . d)))
((_ (x . y) . d)
(cons (quasiquote x . d) (quasiquote y . d)))
((_ #(x ...) . d)
(list->vector (quasiquote (x ...) . d)))
((_ x . d) 'x)))
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
end-clause
. commands)
(let loop ((var init) ...)
(cond end-clause
(else (begin #f . commands)
(loop (begin var . step) ...)))))))
(define-syntax letrec
(syntax-rules ()
((_ ((var init) ...) . body)
(let () (builtin-define var init) ... (let () . body)))))
(define-syntax let*
(syntax-rules ()
((_ () . body) (let () . body))
((_ (first . more) . body)
(let (first) (let* more . body)))))
(define-syntax let
(syntax-rules ()
((_ ((var init) ...) . body)
((lambda (var ...) . body)
init ...))
((_ name ((var init) ...) . body)
((letrec ((name (lambda (var ...) . body)))
name)
init ...))))
(define-syntax case
(syntax-rules (else)
((_ (x . y) . clauses)
(let ((key (x . y)))
(case key . clauses)))
((_ key (else . exps))
(begin #f . exps))
((_ key (atoms . exps) . clauses)
(if (memv key 'atoms) (begin . exps) (case key . clauses)))
((_ key) #f)))
(define-syntax cond
(syntax-rules (else =>)
((_) #f)
((_ (else . exps)) (begin #f . exps))
((_ (x) . rest) (or x (cond . rest)))
((_ (x => proc) . rest)
(let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
((_ (x . exps) . rest)
(if x (begin . exps) (cond . rest)))))
(define-syntax and
(syntax-rules ()
((_) #t)
((_ test) test)
((_ test . tests) (if test (and . tests) #f))))
(define-syntax or
(syntax-rules ()
((_) #f)
((_ test) test)
((_ test . tests) (let ((x test)) (if x x (or . tests))))))
(define-syntax if
(syntax-rules ()
((_ a b) (if* a (lambda () b)))
((_ a b c) (if* a (lambda () b) (lambda () c)))))
(define-syntax delay
(syntax-rules ()
((_ x) (delay* (lambda () x)))))))
(define (delay* thunk) (delay (thunk)))
(define (if* a b . c) (if (null? c) (if a (b)) (if a (b) ((car c)))))
(define (null-env)
((eval `(lambda (cons append list->vector memv delay* if*)
(builtin-define define-syntax
(syntax-rules () ((_ . args) (builtin-define . args))))
(builtin-define define
(syntax-rules ()
((_ (var . args) . body) (define var (lambda args . body)))
((_ var init) (builtin-define var init))))
((lambda ()
,@macro-defs
(let ((let-syntax let) (letrec-syntax letrec))
(get-env)))))
#f)
cons append list->vector memv delay* if*))
(define promise (delay (null-env)))
(lambda (version)
(if (= version 5)
(force promise)
(open-input-file "sheep-herders/r^-1rs.ltx")))))

(define scheme-report-environment
(let-syntax
((extend-env
(syntax-rules ()
((_ env name ...)
((eval '(lambda (name ...) (get-env))
env)
name ...)))))
(let ()
(define (r5-env)
(extend-env (null-environment 5)
eqv? eq? equal?
number? complex? real? rational? integer? exact? inexact?
= < > <= >= zero? positive? negative? odd? even?
max min + * - /
abs quotient remainder modulo gcd lcm numerator denominator
floor ceiling truncate round rationalize
exp log sin cos tan asin acos atan sqrt expt
make-rectangular make-polar real-part imag-part magnitude angle
exact->inexact inexact->exact
number->string string->number
not boolean?
pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
null? list? list length append reverse list-tail list-ref
memq memv member assq assv assoc
symbol? symbol->string string->symbol
char? char=? char<? char>? char<=? char>=?
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
char-alphabetic? char-numeric? char-whitespace?
char-upper-case? char-lower-case?
char->integer integer->char char-upcase char-downcase
string? make-string string string-length string-ref string-set!
string=? string-ci=? string<? string>? string<=? string>=?
string-ci<? string-ci>? string-ci<=? string-ci>=?
substring string-append string->list list->string
string-copy string-fill!
vector? make-vector vector vector-length vector-ref vector-set!
vector->list list->vector vector-fill!
procedure? apply map for-each force
call-with-current-continuation
values call-with-values dynamic-wind
eval scheme-report-environment null-environment
call-with-input-file call-with-output-file
input-port? output-port? current-input-port current-output-port
with-input-from-file with-output-to-file
open-input-file open-output-file close-input-port close-output-port
read read-char peek-char eof-object? char-ready?
write display newline write-char))
(define promise (delay (r5-env)))
(lambda (version)
(if (= version 5)
(force promise)
(open-input-file "sheep-herders/r^-1rs.ltx"))))))

;; Repl provides a simple read-eval-print loop. It semi-supports
;; top-level definitions and syntax definitions, but each one creates
;; a new binding whose region does not include anything that came
;; before the definition, so if you want mutually recursive top-level
;; procedures, you have to do it the hard way:
;; (define f #f)
;; (define (g) (f))
;; (set! f (lambda () (g)))
;; Repl does not support macro uses that expand into top-level definitions.
(define (repl)
(let repl ((env (scheme-report-environment 5)))
(display "eiod> ")
(let ((exp (read)))
(if (not (eof-object? exp))
(case (and (pair? exp) (car exp))
((define define-syntax) (repl (eval `(let () ,exp (get-env))
env)))
(else
(for-each (lambda (val) (write val) (newline))
(call-with-values (lambda () (eval exp env))
list))
(repl env)))))))

;; Footnote:
;; [1] Some claim that this is not required, and that it is compliant for
;;
;; (let* ((x (string #\a))
;; (y (eval x (null-environment 5))))
;; (string-set! x 0 #\b)
;; y)
;;
;; to return "b", but I say that's as bogus as if
;;
;; (let* ((x (string #\1))
;; (y (string->number x)))
;; (string-set! x 0 #\2)
;; y)
;;
;; returned 2. Most implementations disagree with me, however.
;;
;; Note: it would be fine to pass through those strings (and pairs and
;; vectors) that are immutable, but we can't portably detect them.