Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 21:59:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

adding (auto) library for auxiliary syntax

Browse source
This commit is contained in:
Alex Shinn 2020-08-14 11:24:25 +09:00
parent 440b30cf0b
commit d41fac4f73
1 changed files with 42 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
lib/meta-7.scm
View file

@ -91,13 +91,13 @@
((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls)))) ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
(else (id-filter pred (cdr ls))))) (else (id-filter pred (cdr ls)))))
(define (resolve-import x) (define (%resolve-import x)
(cond (cond
((not (and (pair? x) (list? x))) ((not (and (pair? x) (list? x)))
(error "invalid import syntax" x)) (error "invalid import syntax" x))
((and (memq (car x) '(prefix drop-prefix)) ((and (memq (car x) '(prefix drop-prefix))
(symbol? (car (cddr x))) (list? (cadr x))) (symbol? (car (cddr 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 ((if (eq? (car x) 'drop-prefix) (cons ((if (eq? (car x) 'drop-prefix)
@ -110,7 +110,7 @@
(module-exports (find-module (car mod-name+imports)))))))) (module-exports (find-module (car 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))
(let* ((mod-name+imports (resolve-import (cadr x))) (let* ((mod-name+imports (%resolve-import (cadr x)))
(imp-ids (or (cdr mod-name+imports) (imp-ids (or (cdr mod-name+imports)
(and (not (eq? 'only (car x))) (and (not (eq? 'only (car x)))
(module-exports (module-exports
@ -135,6 +135,29 @@
(else (else
(error "couldn't find import" x)))) (error "couldn't find import" x))))
;; slightly roundabout, using eval since we don't have env-define! here
(define (auto-generate-bindings ls)
(let ((bound (env-exports *auto-env*))
(def-aux
(make-syntactic-closure *chibi-env* '() 'define-auxiliary-syntax)))
(let lp ((ls ls) (new '()))
(cond
((null? ls)
(if (pair? new)
(eval `(,(make-syntactic-closure *chibi-env* '() 'begin) ,@new)
*auto-env*)))
(else
(let ((from-id (if (pair? (car ls)) (cdar ls) (car ls))))
(if (memq from-id bound)
(lp (cdr ls) new)
(lp (cdr ls) `((,def-aux ,from-id) ,@new)))))))))
(define (resolve-import x)
(let ((x (%resolve-import x)))
(if (equal? '(auto) (car x))
(auto-generate-bindings (cdr x)))
x))
(define (resolve-module-imports env meta) (define (resolve-module-imports env meta)
(for-each (for-each
(lambda (x) (lambda (x)
@ -415,18 +438,29 @@
(else (else
(error "couldn't find module" (car ls)))))))))))) (error "couldn't find module" (car ls))))))))))))
;; capture a static copy of the current environment to serve
;; as the (chibi) module
(define *chibi-env*
(let ((env (make-environment)))
(%import env (interaction-environment) #f #t)
(env-parent env)))
(define *auto-env*
(let ((env (make-environment)))
(%import env (interaction-environment)
'(_ => ... else unquote unquote-splicing) #t)
(env-parent env)))
(define *modules* (define *modules*
(list (list
(cons '(chibi) (cons '(chibi)
;; capture a static copy of the current environment to serve (make-module #f *chibi-env* '((include "init-7.scm"))))
;; as the (chibi) module
(let ((env (make-environment)))
(%import env (interaction-environment) #f #t)
(make-module #f (env-parent env) '((include "init-7.scm")))))
(cons '(chibi primitive) (cons '(chibi primitive)
(make-module #f #f (lambda (env) (primitive-environment 7)))) (make-module #f #f (lambda (env) (primitive-environment 7))))
(cons '(meta) (cons '(meta)
(make-module #f (current-environment) '((include "meta-7.scm")))) (make-module #f (current-environment) '((include "meta-7.scm"))))
(cons '(auto)
(make-module #f *auto-env* '()))
(cons '(srfi 0) (cons '(srfi 0)
(make-module (list 'cond-expand) (make-module (list 'cond-expand)
(current-environment) (current-environment)