Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
161 lines (138 sloc) 5.18 KB
#lang scheme
(provide (all-defined-out))
(require scheme/path)
(define runtime-get
(case-lambda
((runtime varname)
(namespace-variable-value varname #t #f runtime))
((runtime varname default)
(namespace-variable-value varname #t (lambda () default) runtime))))
(define (runtime-set runtime varname value)
(namespace-set-variable-value! varname value #t runtime))
(define (racket-eval runtime form)
(parameterize ((compile-allow-set!-undefined #t))
(eval form runtime)))
(define (ail-code-eval runtime form)
(cond ((and (pair? form) (eq? (car form) 'ail-code))
(for-each (lambda (expr)
(racket-eval runtime expr))
(cdr form)))
((and (pair? form) (eq? (car form) 'use))
(for-each (lambda (item)
((runtime-get runtime 'use-apply) item))
(cdr form)))
(else
(error "sorry, this primitive eval only knows how to do ail-code and use!" form))))
(define (loadin runtime in)
(let ((form (read in)))
(if (eof-object? form)
'nil
(begin (ail-code-eval runtime form)
((runtime-get runtime 'loadin) in)))))
(define (ail-load runtime filename)
(call-with-input-file filename
(lambda (in)
(loadin runtime in))))
(define (full-path basedir filename)
(path->string
(path->complete-path
filename
(if (or (not basedir) (eqv? basedir 'nil))
(current-directory)
basedir))))
(define (load runtime basedir filename)
((runtime-get runtime 'load)
(full-path (or basedir (current-directory)) filename)))
(define (asstring x)
(cond ((string? x) x)
((symbol? x) (symbol->string x))
(else (error "can't convert to string" x))))
(define (assymbol x)
(cond ((string? x) (string->symbol x))
((symbol? x) x)
(else (error "can't convert to symbol" x))))
(define (dirpart path)
(let-values (((dir file must) (split-path path)))
(path->string dir)))
(define (filepart path)
(let ((r (file-name-from-path path)))
(if r (path->string r) #f)))
(define (extension path)
(let ((r (regexp-match #px"\\.([^\\.]+)$" (filepart path))))
(if r (cadr r) #f)))
(define (default-arc path)
(if (extension path)
path
(string-append path ".arc")))
(define (find file dirs)
(cond ((absolute-path? file)
(cond ((file-exists? file)
file)
((and (not (extension file))
(file-exists? (string-append file ".arc")))
(string-append file ".arc"))
(else
(error "not found" file))))
((eq? dirs 'nil)
(error "not found" file))
(else
(let ((try (string-append (mcar dirs) "/" (default-arc file))))
(if (file-exists? (string->path try))
try
(find file (mcdr dirs)))))))
(define (adir item)
(let-values (((dir file must) (split-path item)))
must))
(define (add-usepath runtime dir)
((runtime-get runtime 'usepath*)
(mcons (path->string (normalize-path dir))
((runtime-get runtime 'usepath*)))))
(define (begins str pat)
(and (<= (string-length pat) (string-length str))
(equal? (substring str 0 (string-length pat)) pat)))
(define (use-apply runtime item)
(let ((loaded* (runtime-get runtime 'loaded*))
(usepath* (runtime-get runtime 'usepath*)))
(cond ((begins (asstring item) "git:")
(use-apply runtime 'use-git)
((runtime-get runtime 'use-apply) item))
((adir (asstring item))
(add-usepath runtime (asstring item)))
(else
(unless (hash-ref loaded* (assymbol item) #f)
(let ((path (find (asstring item) (usepath*))))
(load runtime #f path)
(hash-set! loaded* (assymbol item) 't)))))
't))
(define (new-runtime usepath)
(let ((runtime (make-base-empty-namespace)))
(parameterize ((current-namespace runtime))
(namespace-require '(only scheme/base #%app #%datum #%top))
(namespace-require '(prefix racket- scheme/base))
(namespace-require '(prefix racket- scheme/mpair)))
(runtime-set runtime 'runtime* runtime)
(runtime-set runtime 'usepath* (make-parameter usepath))
(runtime-set runtime 'loaded* (make-hash))
(runtime-set runtime 'ar-racket-eval racket-eval)
(runtime-set runtime 'ar-var
(case-lambda
((name)
(runtime-get runtime name))
((name default)
(runtime-get runtime name default))))
(runtime-set runtime 'ar-assign
(lambda (name value)
(runtime-set runtime name value)))
(runtime-set runtime 'load (lambda (filename) (ail-load runtime filename)))
(runtime-set runtime 'use-apply (lambda (item)
(use-apply runtime item)))
(runtime-set runtime 'loadin (lambda (in)
(loadin runtime in)))
(runtime-set runtime 'add-usepath
(lambda (path)
(add-usepath runtime path)))
(runtime-set runtime 'use-find
(lambda (item (usepath ((runtime-get runtime 'usepath*))))
(find item usepath)))
(runtime-set runtime 'new-runtime new-runtime)
runtime))
Jump to Line
Something went wrong with that request. Please try again.