(scode-library->library library filename))
(r7rs-scode-file-libraries scode)))))
(register-libraries! libraries db)
- (for-each library-eval-result libraries)))
+ (let loop ((libraries libraries) (result unspecific))
+ (if (pair? libraries)
+ (loop (cdr libraries)
+ (let* ((library (car libraries))
+ (result* (library-eval-result library)))
+ (or (library-name library)
+ result*)))
+ result))))
(define (scode-library->library library filename)
(make-library (scode-library-name library)
(let ((p (assq name export-alist)))
(if (not p)
(error "Not an exported name:" name))
- (cdr p))))))
-\f
-;;;; Load
-
-#|
-(define (load db)
- (for-each (lambda (parsed)
- (load-library (syntax-library parsed db)
- db))
- parsed-libraries)
- (if (pair? imports)
- (let ((environment*
- (imports->environment
- (expand-import-sets imports db))))
- (let loop ((exprs body) (value unspecific))
- (if (pair? exprs)
- (loop (cdr exprs)
- (eval (car exprs) environment*))
- value)))))
-
-(define (load-library library-name db)
- (or (db 'get-loaded library-name #f)
- (let ((syntaxed (db 'get-syntaxed library-name)))
- (let ((environment
- (imports->environment
- (syntaxed-library-imports syntaxed)
- db)))
- (scode-eval (syntaxed-library-body syntaxed)
- environment)
- (let ((loaded
- (make-loaded-library (syntaxed-library-name syntaxed)
- (syntaxed-library-exports syntaxed)
- environment)))
- (db 'save-loaded! loaded)
- loaded)))))
-|#
\ No newline at end of file
+ (cdr p))))))
\ No newline at end of file
imports))
(define (define-standard-library name exports)
- (let ((p (assoc name standard-libraries)))
+ (let ((p (assoc name standard-libraries))
+ (exports (extend-with-macro-deps exports)))
(if p
(set-cdr! p exports)
(begin
(define standard-libraries '())
\f
+;; Make sure that the names introduced by macro expansions are also included.
+;; This is a kludge to work around our inability to address names globally.
+(define (extend-with-macro-deps names)
+ (define (scan-new to-scan new names)
+ (cond ((pair? to-scan)
+ (let ((name (car to-scan))
+ (rest (cdr to-scan)))
+ (let ((p (assq name macro-dependencies)))
+ (if p
+ (scan-deps (cdr p) rest new names)
+ (scan-new rest new names)))))
+ ((pair? new)
+ (scan-new new '() names))
+ (else names)))
+
+ (define (scan-deps deps rest new names)
+ (if (pair? deps)
+ (let ((dep (car deps)))
+ (if (memq dep names)
+ (scan-deps (cdr deps) rest new names)
+ (scan-deps (cdr deps)
+ rest
+ (cons dep new)
+ (cons dep names))))
+ (scan-new rest new names)))
+
+ (scan-new names '() names))
+
+(define macro-dependencies
+ '((and if)
+ (and-let* and begin let)
+ (assert error if not)
+ (begin0 let)
+ (bundle alist->bundle cons list)
+ (case begin eq? eqv? if let or quote)
+ (case-lambda apply default-object? error fix:= fix:>= if lambda length let)
+ (circular-stream cons delay letrec)
+ (cond begin if let)
+ (cond-expand begin)
+ (cons-stream cons delay)
+ (cons-stream* cons delay)
+ (define lambda named-lambda)
+ (define-integrable begin lambda let set! shallow-fluid-bind)
+ (define-record-type define new-make-record-type quote record-accessor
+ record-constructor record-modifier record-predicate)
+ (define-values begin call-with-values define lambda set!)
+ (delay delay-force make-promise)
+ (delay-force lambda make-unforced-promise)
+ (do begin if let)
+ (guard begin call-with-current-continuation if lambda let raise-continuable
+ with-exception-handler)
+ (include begin)
+ (include-ci begin)
+ (let declare lambda letrec letrec* named-lambda)
+ (let* let)
+ (let-syntax* let-syntax)
+ (letrec lambda let set!)
+ (letrec* begin lambda let)
+ (local-declare declare let)
+ (parameterize cons lambda list parameterize*)
+ (quasiquote append cons list list->vector quote vector)
+ (receive call-with-values lambda)
+ (unless begin if not)
+ (when begin if)))
+\f
(define-standard-library '(scheme base)
'(*
+
(receive (pathname* loader notifier) (choose-fasload-method pathname)
(if pathname*
(values pathname*
- (wrap-loader pathname (fasloader->loader loader))
+ (wrap-loader pathname (fasloader->loader pathname loader))
notifier)
(let ((pathname*
(if (file-regular? pathname)
(loading-notifier pathname*))
(values #f #f #f)))))))
-(define (fasloader->loader loader)
+(define (fasloader->loader pathname loader)
(lambda (environment purify?)
(let ((scode (loader)))
(if purify? (purify (load/purification-root scode)))
- (extended-scode-eval scode environment))))
+ (if (r7rs-scode-file? scode)
+ (eval-r7rs-scode-file scode pathname (current-load-library-db))
+ (extended-scode-eval scode environment)))))
(define (source-loader pathname)
(lambda (environment purify?)
(define (file-fasloadable? pathname)
(receive (pathname* loader notifier) (choose-fasload-method pathname)
- loader notifier
+ (declare (ignore loader notifier))
(if pathname* #t #f)))
(define (choose-fasload-method pathname)
(runtime unsyntaxer)
(runtime pretty-printer)
(runtime extended-scode-eval)
+ (runtime syntax low)
(runtime syntax items)
(runtime syntax rename)
(runtime syntax top-level)
(syntax-rules ()
((_ predicate name ...)
(alist->bundle predicate
- (list (cons 'name name) ...)))))
\ No newline at end of file
+ (list (cons 'name name) ...)))))
\ No newline at end of file
sc-macro-transformer->keyword-item
spar-classifier->keyword
spar-classifier->runtime
- spar-macro-transformer->keyword-item))
+ spar-macro-transformer->keyword-item
+ top-level-senv))
(define-package (runtime syntax items)
(files "syntax-items")
=> cdr)
((environment-lookup-macro env identifier))
(else
+ (if (not (environment-bound? env identifier))
+ (warn "Reference to unbound variable:" identifier))
;; Capture free runtime references:
(let ((item (var-item identifier)))
(set! free (cons (cons identifier item) free))
form
use-senv
hist
- (runtime-environment->syntactic
- (if (default-object? env)
- system-global-environment
- env)))
+ (if (default-object? env)
+ (top-level-senv)
+ (runtime-environment->syntactic env)))
use-senv
hist))))
+(define-deferred top-level-senv
+ (make-unsettable-parameter #f))
+
(define (syntactic-keyword->item keyword environment)
(let ((item (environment-lookup-macro environment keyword)))
(if (not item)
(get-free)))))))
(define (syntax-internal forms senv)
- (compile-item
- (body-item #f
- (map-in-order (lambda (form)
- (classify-form form senv (initial-hist form)))
- forms))))
+ (parameterize ((top-level-senv senv))
+ (compile-item
+ (body-item #f
+ (map-in-order (lambda (form)
+ (classify-form form senv (initial-hist form)))
+ forms)))))
\f
;;;; Classifier
projects / mit-scheme.git / commitdiff