272 lines
9.9 KiB
Scheme
272 lines
9.9 KiB
Scheme
|
;;; There are two ways to name a library: (foo bar) or foo.bar
|
||
|
|
;;; The former is normalized to the latter.
|
||
|
|
|
||
|
|
(define (mangle name)
|
||
|
|
(when (null? name)
|
||
|
|
(error "library name should be a list of at least one symbols" name))
|
||
|
|
|
||
|
|
(define (->string n)
|
||
|
|
(cond
|
||
|
|
((symbol? n)
|
||
|
|
(let ((str (symbol->string n)))
|
||
|
|
(string-for-each
|
||
|
|
(lambda (c)
|
||
|
|
(when (or (char=? c #\.) (char=? c #\:))
|
||
|
|
(error "elements of library name may not contain '.' or ':'" n)))
|
||
|
|
str)
|
||
|
|
str))
|
||
|
|
((and (number? n) (exact? n) (<= 0 n))
|
||
|
|
(number->string n))
|
||
|
|
(else
|
||
|
|
(error "symbol or non-negative integer is required" n))))
|
||
|
|
|
||
|
|
(define (join strs delim)
|
||
|
|
(let loop ((res (car strs)) (strs (cdr strs)))
|
||
|
|
(if (null? strs)
|
||
|
|
res
|
||
|
|
(loop (string-append res delim (car strs)) (cdr strs)))))
|
||
|
|
|
||
|
|
(if (symbol? name)
|
||
|
|
name ; TODO: check symbol names
|
||
|
|
(string->symbol (join (map ->string name) "."))))
|
||
|
|
|
||
|
|
(define current-library
|
||
|
|
(make-parameter '(picrin base) mangle))
|
||
|
|
|
||
|
|
(define *libraries*
|
||
|
|
(make-dictionary))
|
||
|
|
|
||
|
|
(define (find-library name)
|
||
|
|
(dictionary-has? *libraries* (mangle name)))
|
||
|
|
|
||
|
|
(define (make-library name)
|
||
|
|
(let ((name (mangle name)))
|
||
|
|
(let ((env (make-environment
|
||
|
|
(string->symbol (string-append (symbol->string name) ":"))))
|
||
|
|
(exports (make-dictionary)))
|
||
|
|
;; set up initial environment
|
||
|
|
(set-identifier! 'define-library 'define-library env)
|
||
|
|
(set-identifier! 'import 'import env)
|
||
|
|
(set-identifier! 'export 'export env)
|
||
|
|
(set-identifier! 'cond-expand 'cond-expand env)
|
||
|
|
(dictionary-set! *libraries* name `(,env . ,exports)))))
|
||
|
|
|
||
|
|
(define (library-environment name)
|
||
|
|
(car (dictionary-ref *libraries* (mangle name))))
|
||
|
|
|
||
|
|
(define (library-exports name)
|
||
|
|
(cdr (dictionary-ref *libraries* (mangle name))))
|
||
|
|
|
||
|
|
(define (library-import name sym alias)
|
||
|
|
(let ((uid (dictionary-ref (library-exports name) sym)))
|
||
|
|
(let ((env (library-environment (current-library))))
|
||
|
|
(set-identifier! alias uid env))))
|
||
|
|
|
||
|
|
(define (library-export sym alias)
|
||
|
|
(let ((env (library-environment (current-library)))
|
||
|
|
(exports (library-exports (current-library))))
|
||
|
|
(dictionary-set! exports alias (find-identifier sym env))))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;; R7RS library syntax
|
||
|
|
|
||
|
|
(define-macro define-library
|
||
|
|
(lambda (form _)
|
||
|
|
(let ((name (cadr form))
|
||
|
|
(body (cddr form)))
|
||
|
|
(or (find-library name) (make-library name))
|
||
|
|
(parameterize ((current-library name))
|
||
|
|
(for-each
|
||
|
|
(lambda (expr)
|
||
|
|
(eval expr name)) ; TODO parse library declarations
|
||
|
|
body)))))
|
||
|
|
|
||
|
|
(define-macro cond-expand
|
||
|
|
(lambda (form _)
|
||
|
|
(letrec
|
||
|
|
((test (lambda (form)
|
||
|
|
(or
|
||
|
|
(eq? form 'else)
|
||
|
|
(and (symbol? form)
|
||
|
|
(memq form (features)))
|
||
|
|
(and (pair? form)
|
||
|
|
(case (car form)
|
||
|
|
((library) (find-library (cadr form)))
|
||
|
|
((not) (not (test (cadr form))))
|
||
|
|
((and) (let loop ((form (cdr form)))
|
||
|
|
(or (null? form)
|
||
|
|
(and (test (car form)) (loop (cdr form))))))
|
||
|
|
((or) (let loop ((form (cdr form)))
|
||
|
|
(and (pair? form)
|
||
|
|
(or (test (car form)) (loop (cdr form))))))
|
||
|
|
(else #f)))))))
|
||
|
|
(let loop ((clauses (cdr form)))
|
||
|
|
(if (null? clauses)
|
||
|
|
#undefined
|
||
|
|
(if (test (caar clauses))
|
||
|
|
`(,the-begin ,@(cdar clauses))
|
||
|
|
(loop (cdr clauses))))))))
|
||
|
|
|
||
|
|
(define-macro import
|
||
|
|
(lambda (form _)
|
||
|
|
(let ((caddr
|
||
|
|
(lambda (x) (car (cdr (cdr x)))))
|
||
|
|
(prefix
|
||
|
|
(lambda (prefix symbol)
|
||
|
|
(string->symbol
|
||
|
|
(string-append
|
||
|
|
(symbol->string prefix)
|
||
|
|
(symbol->string symbol)))))
|
||
|
|
(getlib
|
||
|
|
(lambda (name)
|
||
|
|
(if (find-library name)
|
||
|
|
name
|
||
|
|
(error "library not found" name)))))
|
||
|
|
(letrec
|
||
|
|
((extract
|
||
|
|
(lambda (spec)
|
||
|
|
(case (car spec)
|
||
|
|
((only rename prefix except)
|
||
|
|
(extract (cadr spec)))
|
||
|
|
(else
|
||
|
|
(getlib spec)))))
|
||
|
|
(collect
|
||
|
|
(lambda (spec)
|
||
|
|
(case (car spec)
|
||
|
|
((only)
|
||
|
|
(let ((alist (collect (cadr spec))))
|
||
|
|
(map (lambda (var) (assq var alist)) (cddr spec))))
|
||
|
|
((rename)
|
||
|
|
(let ((alist (collect (cadr spec)))
|
||
|
|
(renames (map (lambda (x) `(,(car x) . ,(cadr x))) (cddr spec))))
|
||
|
|
(map (lambda (s) (or (assq (car s) renames) s)) alist)))
|
||
|
|
((prefix)
|
||
|
|
(let ((alist (collect (cadr spec))))
|
||
|
|
(map (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))
|
||
|
|
((except)
|
||
|
|
(let ((alist (collect (cadr spec))))
|
||
|
|
(let loop ((alist alist))
|
||
|
|
(if (null? alist)
|
||
|
|
'()
|
||
|
|
(if (memq (caar alist) (cddr spec))
|
||
|
|
(loop (cdr alist))
|
||
|
|
(cons (car alist) (loop (cdr alist))))))))
|
||
|
|
(else
|
||
|
|
(dictionary-map (lambda (x) (cons x x))
|
||
|
|
(library-exports (getlib spec))))))))
|
||
|
|
(letrec
|
||
|
|
((import
|
||
|
|
(lambda (spec)
|
||
|
|
(let ((lib (extract spec))
|
||
|
|
(alist (collect spec)))
|
||
|
|
(for-each
|
||
|
|
(lambda (slot)
|
||
|
|
(library-import lib (cdr slot) (car slot)))
|
||
|
|
alist)))))
|
||
|
|
(for-each import (cdr form)))))))
|
||
|
|
|
||
|
|
(define-macro export
|
||
|
|
(lambda (form _)
|
||
|
|
(letrec
|
||
|
|
((collect
|
||
|
|
(lambda (spec)
|
||
|
|
(cond
|
||
|
|
((symbol? spec)
|
||
|
|
`(,spec . ,spec))
|
||
|
|
((and (list? spec) (= (length spec) 3) (eq? (car spec) 'rename))
|
||
|
|
`(,(list-ref spec 1) . ,(list-ref spec 2)))
|
||
|
|
(else
|
||
|
|
(error "malformed export")))))
|
||
|
|
(export
|
||
|
|
(lambda (spec)
|
||
|
|
(let ((slot (collect spec)))
|
||
|
|
(library-export (car slot) (cdr slot))))))
|
||
|
|
(for-each export (cdr form)))))
|
||
|
|
|
||
|
|
|
||
|
|
;;; bootstrap...
|
||
|
|
(let ()
|
||
|
|
(make-library '(picrin base))
|
||
|
|
(set-car! (dictionary-ref *libraries* (mangle '(picrin base))) default-environment)
|
||
|
|
(let ((export-keywords
|
||
|
|
(lambda (keywords)
|
||
|
|
(let ((env (library-environment '(picrin base)))
|
||
|
|
(exports (library-exports '(picrin base))))
|
||
|
|
(for-each
|
||
|
|
(lambda (keyword)
|
||
|
|
(dictionary-set! exports keyword keyword))
|
||
|
|
keywords)))))
|
||
|
|
(export-keywords
|
||
|
|
'(define lambda quote set! if begin define-macro
|
||
|
|
let let* letrec letrec*
|
||
|
|
let-values let*-values define-values
|
||
|
|
quasiquote unquote unquote-splicing
|
||
|
|
and or
|
||
|
|
cond case else =>
|
||
|
|
do when unless
|
||
|
|
parameterize
|
||
|
|
define-syntax
|
||
|
|
syntax-quote syntax-unquote
|
||
|
|
syntax-quasiquote syntax-unquote-splicing
|
||
|
|
let-syntax letrec-syntax
|
||
|
|
syntax-error))
|
||
|
|
(export-keywords
|
||
|
|
'(features
|
||
|
|
eq? eqv? equal? not boolean? boolean=?
|
||
|
|
pair? cons car cdr null? set-car! set-cdr!
|
||
|
|
caar cadr cdar cddr
|
||
|
|
list? make-list list length append reverse
|
||
|
|
list-tail list-ref list-set! list-copy
|
||
|
|
map for-each memq memv member assq assv assoc
|
||
|
|
current-input-port current-output-port current-error-port
|
||
|
|
port? input-port? output-port? port-open? close-port
|
||
|
|
eof-object? eof-object
|
||
|
|
read-u8 peek-u8 read-bytevector!
|
||
|
|
write-u8 write-bytevector flush-output-port
|
||
|
|
open-input-bytevector open-output-bytevector get-output-bytevector
|
||
|
|
number? exact? inexact? inexact exact
|
||
|
|
= < > <= >= + - * /
|
||
|
|
number->string string->number
|
||
|
|
procedure? apply
|
||
|
|
symbol? symbol=? symbol->string string->symbol
|
||
|
|
make-identifier identifier? identifier=? identifier-base identifier-environment
|
||
|
|
vector? vector make-vector vector-length vector-ref vector-set!
|
||
|
|
vector-copy! vector-copy vector-append vector-fill! vector-map vector-for-each
|
||
|
|
list->vector vector->list string->vector vector->string
|
||
|
|
bytevector? bytevector make-bytevector
|
||
|
|
bytevector-length bytevector-u8-ref bytevector-u8-set!
|
||
|
|
bytevector-copy! bytevector-copy bytevector-append
|
||
|
|
bytevector->list list->bytevector
|
||
|
|
call-with-current-continuation call/cc values call-with-values
|
||
|
|
char? char->integer integer->char char=? char<? char>? char<=? char>=?
|
||
|
|
current-exception-handlers with-exception-handler
|
||
|
|
raise raise-continuable error
|
||
|
|
error-object? error-object-message error-object-irritants
|
||
|
|
error-object-type
|
||
|
|
string? string make-string string-length string-ref string-set!
|
||
|
|
string-copy string-copy! string-fill! string-append
|
||
|
|
string-map string-for-each list->string string->list
|
||
|
|
string=? string<? string>? string<=? string>=?
|
||
|
|
make-parameter with-dynamic-environment
|
||
|
|
read
|
||
|
|
make-dictionary dictionary? dictionary dictionary-has?
|
||
|
|
dictionary-ref dictionary-set! dictionary-delete! dictionary-size
|
||
|
|
dictionary-map dictionary-for-each
|
||
|
|
dictionary->alist alist->dictionary dictionary->plist plist->dictionary
|
||
|
|
make-record record? record-type record-datum
|
||
|
|
default-environment make-environment find-identifier set-identifier!
|
||
|
|
eval
|
||
|
|
make-ephemeron-table
|
||
|
|
write write-simple write-shared display))
|
||
|
|
(export-keywords
|
||
|
|
'(find-library make-library current-library)))
|
||
|
|
(set! eval
|
||
|
|
(let ((e eval))
|
||
|
|
(lambda (expr . lib)
|
||
|
|
(let ((lib (if (null? lib) (current-library) (car lib))))
|
||
|
|
(e expr (library-environment lib))))))
|
||
|
|
(make-library '(picrin user))
|
||
|
|
(current-library '(picrin user)))
|
||
|
|
|