conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* multiple imports of the same binding into the same context now work.

This commit is contained in:
Abdulaziz Ghuloum 2007-11-12 05:01:25 -05:00
parent 880a6f8efd
commit c26ef04965
3 changed files with 26 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
scheme/ikarus.boot.orig
View File

Binary file not shown.

10
scheme/makefile.ss
View File

@ -14,14 +14,14 @@
;;; You should have received a copy of the GNU General Public License ;;; You should have received a copy of the GNU General Public License
;;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
(import (only (ikarus) import))
(import (except (ikarus) assembler-output) (import (except (ikarus) assembler-output))
(ikarus compiler) (import (ikarus compiler))
(except (psyntax system $bootstrap) (import (except (psyntax system $bootstrap)
eval-core eval-core
current-primitive-locations current-primitive-locations
compile-core-expr-to-port)) compile-core-expr-to-port))
(import (ikarus compiler)) ; just for fun
(define scheme-library-files (define scheme-library-files
;;; Listed in the order in which they're loaded. ;;; Listed in the order in which they're loaded.

27
scheme/psyntax.expander.ss
View File

@ -108,23 +108,29 @@
;;; #<rib list-of-symbols list-of-list-of-marks list-of-labels #f> ;;; #<rib list-of-symbols list-of-list-of-marks list-of-labels #f>
(define (extend-rib! rib id label) (define (extend-rib! rib id label)
(define (find sym mark* sym* mark**) (define (find sym mark* sym* mark** label*)
(and (pair? sym*) (and (pair? sym*)
(or (and (eq? sym (car sym*)) (if (and (eq? sym (car sym*)) (same-marks? mark* (car mark**)))
(same-marks? mark* (car mark**))) (car label*)
(find sym mark* (cdr sym*) (cdr mark**))))) (find sym mark* (cdr sym*) (cdr mark**) (cdr label*)))))
(when (rib-sealed/freq rib) (when (rib-sealed/freq rib)
(error 'extend-rib! "rib is sealed" rib)) (error 'extend-rib! "rib is sealed" rib))
(let ((sym (id->sym id)) (mark* (stx-mark* id))) (let ((sym (id->sym id))
(mark* (stx-mark* id)))
(let ((sym* (rib-sym* rib))) (let ((sym* (rib-sym* rib)))
(when (and (memq sym (rib-sym* rib)) (cond
(find sym mark* sym* (rib-mark** rib))) [(and (memq sym (rib-sym* rib))
(find sym mark* sym* (rib-mark** rib) (rib-label* rib)))
=>
(lambda (label^)
(unless (eq? label label^)
;;; signal an error if the identifier was already ;;; signal an error if the identifier was already
;;; in the rib. ;;; in the rib.
(stx-error id "cannot redefine")) (stx-error id "cannot redefine")))]
[else
(set-rib-sym*! rib (cons sym sym*)) (set-rib-sym*! rib (cons sym sym*))
(set-rib-mark**! rib (cons mark* (rib-mark** rib))) (set-rib-mark**! rib (cons mark* (rib-mark** rib)))
(set-rib-label*! rib (cons label (rib-label* rib)))))) (set-rib-label*! rib (cons label (rib-label* rib)))]))))
;;; A rib can be sealed once all bindings are inserted. To seal ;;; A rib can be sealed once all bindings are inserted. To seal
;;; a rib, we convert the lists sym*, mark**, and label* to vectors ;;; a rib, we convert the lists sym*, mark**, and label* to vectors
@ -2629,7 +2635,8 @@
(let ([name (car x)]) (let ([name (car x)])
(datum->stx ctxt name))) (datum->stx ctxt name)))
subst) subst)
(map cdr subst)))])) (map cdr subst)))]
[_ (stx-error e "invalid import form")]))
(let-values (((id* lab*) (let-values (((id* lab*)
(if (module-import? e) (if (module-import? e)
(module-import e r) (module-import e r)