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