Changeset 5139 in project for lexmod/lexmod-base.scm


Ignore:
Timestamp:
07/17/07 18:02:56 (13 years ago)
Author:
Kon Lovett
Message:

Added structures like functionality.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • lexmod/lexmod-base.scm

    r2659 r5139  
     1(cond-expand
     2  (chicken
     3    (use srfi-1)
     4    (eval-when (compile)
     5      (declare
     6        (usual-integrations)
     7        (no-procedure-checks)
     8        (inline)
     9        (fixnum)
     10#| THIS CAUSES THE ENTIRE BUILTIN SYMBOL TABLE TO VANISH!
     11        (import
     12          ##sys#setslot)
     13        (bound-to-procedure
     14          ##sys#setslot)
     15|#
     16        (export
     17          lexmod:get-defined-tag
     18          lexmod:get-modname-tag
     19          lexmod:assert-satisfies
     20          lexmod-version
     21          interface?
     22          interface-exports?
     23          lexmod-name
     24          lexmod-exports?
     25          lexmod-satisfies?
     26          lexmod-fulfills?
     27          lexmod?
     28          lexmod-open
     29          compound-lexmod) ) ) )
     30  (else) )
     31
    132;;; (C) 2003 Taylor Campbell.
    233;;; All rights reserved.
     
    536;;; lexmod distribution.
    637
    7 (define (lexmod-version) '(008 final)) ; fnord
     38(define (lexmod-version) '(009 final)) ; fnord
    839
    940(define lexmod:get-defined-tag "get-defined")
     
    4576             mod
    4677             interface)))
     78
     79;;
     80
     81(cond-expand
     82  (chicken
     83    (define (check-lexmod obj loc)
     84      (unless (lexmod? obj)
     85        (error loc "invalid lexmod" obj)) )
     86
     87    (define (%lexmod? obj)
     88      (and (procedure? obj)
     89           (call/cc
     90             (lambda (k)
     91               (with-exception-handler
     92                 (lambda (exp) (k #f))
     93                 (lambda () (lexmod-name obj))))) ) )
     94
     95    (define (lexmod-fulfills? mod . exps)
     96      (every
     97        (lambda (exp)
     98          (cond
     99            [(and (pair? exp) (eq? 'export (car exp)))
     100              (every (cut lexmod-exports? mod <>) (cdr exp))]
     101            [(interface? exp)
     102              (lexmod-satisfies? mod exp)]
     103            [else
     104              (error 'lexmod? "invalid export syntax" exp)]) )
     105        exps) )
     106
     107    (define (lexmod? obj . exps)
     108      (and (%lexmod? obj)
     109           (or (null? exps)
     110               (apply lexmod-fulfills? exps) ) ) )
     111
     112    (define (lexmod-open . mods)
     113      (for-each
     114        (lambda (mod)
     115          (check-lexmod mod 'lexmod-open)
     116          (for-each
     117            (lambda (sym)
     118              (##sys#setslot sym 0 (mod sym)))
     119            (hash-table-keys (mod lexmod:get-defined-tag))) )
     120        mods) )
     121
     122    ; Two ways to implement:
     123    ; using lexmod macro or using knowledge of lexmod macro
     124
     125    (define (compound-lexmod . mods)
     126      (let ([*defined* (make-hash-table eq?)]
     127            [*name* ""])
     128        (for-each
     129          (lambda (mod)
     130            (check-lexmod mod 'compound-lexmod)
     131            (let ([syms (hash-table-keys (mod lexmod:get-defined-tag))])
     132              (let ([dups (lset-intersection eq? (hash-table-keys *defined*) syms)])
     133                (unless (null? dups)
     134                  (error 'compound-lexmod "multiply defined exports" dups) ) )
     135              (set! *name* (string-append *name* "+" (lexmod-name mod)))
     136              (for-each
     137                (lambda (sym)
     138                  (hash-table-set! *defined* sym (mod sym)) )
     139                syms) ) )
     140          mods)
     141        (set! *name* (string->symbol *name*))
     142        (lambda (x)
     143           (cond ((symbol? x)
     144                  (hash-table-ref *defined* x
     145                    (lambda () (error *name* "unknown name in module" x))))
     146                 ((eq? x lexmod:get-defined-tag) *defined*)
     147                 ((eq? x lexmod:get-modname-tag) *name*)
     148                 (else (error *name* "invalid argument" x)) ) ) ) ) )
     149  (else) )
Note: See TracChangeset for help on using the changeset viewer.