Changeset 5139 in project


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

Added structures like functionality.

Location:
lexmod
Files:
3 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) )
  • lexmod/lexmod.scm

    r2659 r5139  
    55;;; lexmod distribution.
    66
     7#;
    78(define-syntax lexmod
    89  (syntax-rules (export)
     
    2223                            '?name
    2324                            x))))))))
     25
     26(define-syntax lexmod
     27  (syntax-rules (export)
     28    ((_ ?name (export ?exported ...) ?defn ...)
     29     (let ((*defined* (make-hash-table eq?)))
     30       ?defn ...
     31       (lexmod:expand-exports *defined* ?exported ...)
     32       (lambda (x)
     33         (cond ((symbol? x)
     34                (hash-table-ref *defined* x
     35                  (lambda () (error '?name "unknown name in lexmod" x))))
     36               ((eq? x lexmod:get-defined-tag) *defined*)
     37               ((eq? x lexmod:get-modname-tag) '?name)
     38               (else (error '?name "invalid lexmod argument" x))))))))
    2439
    2540;;; Commented out is the hack to surround each subform in a LET.
     
    199214       ...
    200215       new))))
     216
     217(define-syntax define-interface
     218  (syntax-rules ()
     219    ((_ ?name ?symbol ...)
     220     (define ?name (interface ?symbol ...)))))
    201221
    202222(define-syntax lexmod:syntax-gentemps
  • lexmod/lexmod.setup

    r2659 r5139  
    1 (compile -s -O2 -d0 lexmod-base.scm)
    2 (install-extension
    3  'lexmod
     1(define has-exports? (string>=? (chicken-version) "2.310"))
     2
     3(compile -s -O2 -d0
     4        ,@(if has-exports? '(-check-imports -emit-exports lexmod.exports) '())
     5 lexmod-base.scm)
     6
     7(install-extension 'lexmod
    48 '("lexmod.scm" "lexmod.html" "lexmod-base.so")
    5  '((version "008")
     9 `((version "009")
     10   ,@(if has-exports? `((exports "lexmod.exports")) '())
    611   (documentation "lexmod.html")
    712   (examples "lexmod-examples.scm")
Note: See TracChangeset for help on using the changeset viewer.