Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 22:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding support for (import (drop-prefix (lib foo) foo-)).

Browse source
This commit is contained in:
Alex Shinn 2012-04-16 23:30:17 +09:00
parent 6122ae3ff7
commit 323aa88eb4
1 changed files with 16 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
lib/meta.scm
View file

@ -49,6 +49,14 @@
(define (symbol-append a b)
(string->symbol (string-append (symbol->string a) (symbol->string b))))
(define (symbol-drop a b)
(let ((as (symbol->string a))
(bs (symbol->string b)))
(if (and (> (string-length bs) (string-length as))
(string=? as (substring bs 0 (string-length as))))
(string->symbol (substring bs (string-length as)))
b)))
;; (define (warn msg . args)
;; (display msg (current-error-port))
;; (display ":" (current-error-port))
@ -69,12 +77,17 @@
(cond
((not (and (pair? x) (list? x)))
(error "invalid module syntax" x))
((and (eq? 'prefix (car x)) (symbol? (caddr x)) (list? (cadr x)))
((and (memq (car x) '(prefix drop-prefix))
(symbol? (caddr x)) (list? (cadr x)))
(let ((mod-name+imports (resolve-import (cadr x))))
(cons (car mod-name+imports)
(map (lambda (i)
(cons (symbol-append (caddr x) (if (pair? i) (car i) i))
(if (pair? i) (cdr i) i)))
(cons ((if (eq? (car x) 'drop-prefix)
symbol-drop
symbol-append)
(caddr x)
(to-id i))
(from-id i)))
(cdr mod-name+imports)))))
((and (pair? (cdr x)) (pair? (cadr x)))
(if (memq (car x) '(only except rename))