Changeset 5973 in project


Ignore:
Timestamp:
09/10/07 22:07:14 (12 years ago)
Author:
felix winkelmann
Message:
  • removed some namespace stuff from compiler and runtime-system , including "namespace" declaration
  • added "uid" arguments to symbol-table handling functions
  • added "#[...]" read and print syntax
  • some minor fixes in defaults.make and rules.make
Location:
chicken/branches/context
Files:
10 edited

Legend:

Unmodified
Added
Removed
  • chicken/branches/context/c-backend.scm

    r5501 r5973  
    4444  standard-bindings-that-never-return-false side-effect-free-standard-bindings-that-never-return-false
    4545  installation-home optimization-iterations debugging cleanup
    46   file-io-only namespace-table
     46  file-io-only
    4747  unit-name insert-timer-checks used-units inlining external-variables
    4848  foreign-declarations emit-trace-info block-compilation line-number-database-size
     
    7979  default-optimization-iterations generate-foreign-callback-header generate-foreign-callback-stub-prototypes
    8080  generate-code make-variable-list make-argument-list generate-foreign-stubs foreign-type-declaration
    81   foreign-argument-conversion foreign-result-conversion quick-namespace-list setup-quick-namespace-list
    82   namespace-lookup compute-namespace-size}
     81  foreign-argument-conversion foreign-result-conversion}
    8382
    8483(include "tweaks")
     
    102101   (intersperse lst #\space) ) )
    103102
    104 (define (compute-namespace-size n)
    105   37)                                   ; Arbitrary...
    106 
    107103
    108104;;; Unique id/prefix:
     
    111107  (string->c-identifier
    112108   (sprintf "C_~X_~A_" (random #x1000000) (current-seconds)) ) )
    113 
    114 
    115 ;;; Check name for namespace:
    116 ;;
    117 ;; This stuff is basically not needed. The namespace thingy once looked good, but
    118 ;; can not replace a proper module system. It's still available, and might be
    119 ;; handy for certain hacks.
    120 
    121 (define quick-namespace-list '())
    122 
    123 (define (setup-quick-namespace-list)
    124   (for-each
    125    (lambda (ns)
    126      (set! quick-namespace-list (append (cdr ns) quick-namespace-list)) )
    127    namespace-table) )
    128 
    129 (define (namespace-lookup sym)
    130   (and (memq sym quick-namespace-list)
    131        (let loop ([nslist namespace-table] [i 0])
    132          (cond [(null? nslist) (bomb "symbol not in namespace" sym)]
    133                [(memq sym (cdar nslist)) i]
    134                [else (loop (cdr nslist) (add1 i))] ) ) ) )
    135109
    136110
     
    663637            [(string? lit) 0]
    664638            [(number? lit) words-per-flonum]
    665             [(symbol? lit) (fx+ (if (##sys#fudge 31) 1 0) 9)]           ; size of symbol, and possibly a bucket
     639            [(symbol? lit) (fx+ (if (##sys#fudge 33) 1 0) 10)]          ; size of symbol, and possibly a bucket
    666640            [(pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))]
    667641            [(vector? lit) (+ 1 (vector-length lit) (reduce + 0 (map literal-size (vector->list lit))))]
     
    740714            ((vector? lit) (gen-vector-like-lit to lit "C_h_vector"))
    741715            ((symbol? lit)
    742              (let* ([str (##sys#slot lit 1)]
    743                     [cstr (c-ify-string str)]
    744                     [len (##sys#size str)]
    745                     [nsi (namespace-lookup lit)] )
     716             (let* ((str (##sys#slot lit 1))
     717                    (cstr (c-ify-string str))
     718                    (len (##sys#size str))
     719                    (uid (##sys#slot lit 2)) )
     720               (when uid (gen-lit uid "tmp" lf))
    746721               (gen #t to "=")
    747                (if nsi
    748                    (if lf
    749                        (gen "C_h_intern_in(&" to #\, len #\, cstr ",stable" nsi ");")
    750                        (gen "C_intern_in(C_heaptop," len #\, cstr ",stable" nsi ");") )
    751                    (if lf
    752                        (gen "C_h_intern(&" to #\, len #\, cstr ");")
    753                        (gen "C_intern(C_heaptop," len #\, cstr ");") ) ) ) )
     722               (if lf
     723                   (gen "C_h_intern" (if uid "_c" "") "(&" to #\, len #\, (if uid "tmp," "") cstr ");")
     724                   (gen "C_intern" (if uid "_c" "") "(C_heaptop," len #\, (if uid "tmp," "") cstr ");") ) ) )
    754725            ((##sys#immediate? lit) (bad-literal lit))
    755726            ((##sys#bytevector? lit)
     
    852823                 (gen #t "C_word t" i #\;) ) )
    853824           (cond [(eq? 'toplevel id)
    854                   (do ([i 0 (add1 i)]
    855                        [ns namespace-table (cdr ns)] )
    856                       ((null? ns))
    857                     (gen #t "C_SYMBOL_TABLE *stable" i #\;) )
    858825                  (let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
    859826                        [llen (length literals)] )
     
    861828                         #t "if(toplevel_initialized) C_kontinue(t1,C_SCHEME_UNDEFINED);"
    862829                         #t "else C_toplevel_entry(C_text(\"" topname "\"));")
    863                     (do ([i 0 (add1 i)]
    864                          [ns namespace-table (cdr ns)] )
    865                         ((null? ns))
    866                       (gen #t "stable" i "=C_new_symbol_table(\""
    867                            (caar ns) "\"," (compute-namespace-size (cdar ns)) ");") )
    868830                    (when disable-stack-overflow-checking
    869831                      (gen #t "C_disable_overflow_check=1;") )
     
    990952    (generate-foreign-callback-stubs foreign-callback-stubs db)
    991953    (trampolines)
    992     (setup-quick-namespace-list)
    993954    (procedures)
    994955    (emit-procedure-table-info lambdas source-file)
  • chicken/branches/context/c-platform.scm

    r5358 r5973  
    201201    ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number
    202202    ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
    203     ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )
     203    ##sys#intern-symbol ##sys#intern-symbol/context ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )
    204204
    205205(define side-effecting-standard-bindings
     
    233233    u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
    234234    u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
    235     ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
     235    ##sys#intern-symbol ##sys#intern-symbol/context ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
    236236
    237237(define foldable-extended-bindings
     
    799799(rewrite '##sys#context-switch 13 "C_context_switch" #t)
    800800(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t)
     801(rewrite '##sys#intern-symbol/context 13 "C_string_to_symbol_c" #t)
    801802(rewrite '##sys#make-symbol 13 "C_make_symbol" #t)
    802803
  • chicken/branches/context/chicken.h

    r5853 r5973  
    365365#define C_SIZEOF_STRING(n)        (C_bytestowords(n) + 2)
    366366#ifdef C_EXTRA_SYMBOL_SLOT
     367# define C_SIZEOF_SYMBOL          5
     368#else
    367369# define C_SIZEOF_SYMBOL          4
    368 #else
    369 # define C_SIZEOF_SYMBOL          3
    370370#endif
    371371#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
     
    11651165C_fctexport C_word C_fcall C_intern(C_word **ptr, int len, C_char *str) C_regparm;
    11661166C_fctexport C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
     1167C_fctexport C_word C_fcall C_intern_in_c(C_word **ptr, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable) C_regparm;
    11671168C_fctexport C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str) C_regparm;
    11681169C_fctexport C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
     1170C_fctexport C_word C_fcall C_h_intern_in_c(C_word *slot, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable) C_regparm;
    11691171C_fctexport C_word C_fcall C_intern2(C_word **ptr, C_char *str) C_regparm;
    11701172C_fctexport C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value) C_regparm;
     
    12701272C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C_word size, C_word type, C_word init, C_word align8) C_noret;
    12711273C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
     1274C_fctexport void C_ccall C_string_to_symbol_c(C_word c, C_word closure, C_word k, C_word string, C_word uid) C_noret;
    12721275C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
    12731276C_fctexport void C_ccall C_cons_flonum(C_word c, C_word closure, C_word k) C_noret;
  • chicken/branches/context/compiler.scm

    r5853 r5973  
    7171; (compress-literals [<threshold>])
    7272; (safe-globals)
    73 ; (namespace <name> {<symbol})
    7473; (custom-declare (<tag> <name> <filename> <arg> ...) <string> ...)
    7574; (data <tag1> <exp1> ...)
     
    270269  broken-constant-nodes inline-substitutions-enabled loop-lambda-names expand-profile-lambda
    271270  profile-lambda-list profile-lambda-index emit-profile expand-profile-lambda
    272   direct-call-ids foreign-type-table first-analysis callback-names namespace-table disabled-warnings
     271  direct-call-ids foreign-type-table first-analysis callback-names disabled-warnings
    273272  initialize-compiler canonicalize-expression expand-foreign-lambda update-line-number-database! scan-toplevel-assignments
    274273  compiler-warning import-table use-import-table compiler-macro-table compiler-macros-enabled
     
    368367(define explicit-use-flag #f)
    369368(define disable-stack-overflow-checking #f)
    370 (define namespace-table '())
    371369(define require-imports-flag #f)
    372370(define emit-unsafe-marker #f)
     
    11851183                n
    11861184                (quit "invalid argument to `inline-limit' declaration" spec) ) ) ) )
    1187        ((namespace)
    1188         (check-decl spec 2)
    1189         (let* ([syms (cdr spec)]
    1190                [ns (car syms)] )
    1191           (if (every symbol? syms)
    1192               (let ([oldsyms (or (and-let* ([a (assq ns namespace-table)]) (cdr a)) '())])
    1193                 (set! namespace-table
    1194                   (alist-update! ns (lset-union eq? oldsyms (cdr syms)) namespace-table eq?) ) )
    1195               (quit "invalid arguments to `namespace' declaration: ~S" spec) ) ) )
    11961185       ((constant)
    11971186        (let ((syms (cdr spec)))
  • chicken/branches/context/defaults.make

    r5945 r5973  
    3636# basic parameters
    3737
    38 BINARYVERSION = 1
     38BINARYVERSION = 2
    3939NURSERY = (128*1024)
    4040STACKDIRECTION = 1
     
    121121ASSEMBLER_OUTPUT_OPTION ?= -o
    122122ASSEMBLER_COMPILE_OPTION ?= -c
    123 PRIMARY_LIBCHICKEN ?= libchicken$(SO)
    124123UNINSTALLINFO_PROGRAM_OPTIONS ?= --delete
    125124HOST_C_COMPILER_OUTPUT_OPTION ?= $(C_COMPILER_OUTPUT_OPTION)
     
    164163CHICKEN_SHARED_EXECUTABLE = chicken-shared$(EXE)
    165164CSI_SHARED_EXECUTABLE = csi-shared$(EXE)
     165PRIMARY_LIBCHICKEN ?= libchicken$(A)
    166166TARGETS ?= libchicken$(A) libuchicken$(A) $(CHICKEN_STATIC_EXECUTABLE) \
    167167        $(CSI_STATIC_EXECUTABLE) chicken-profile$(EXE) csc$(EXE) \
     
    172172CHICKEN_SHARED_EXECUTABLE = chicken$(EXE)
    173173CSI_SHARED_EXECUTABLE = csi$(EXE)
     174PRIMARY_LIBCHICKEN ?= libchicken$(SO)
    174175TARGETS ?= libchicken$(A) libuchicken$(A) $(CHICKEN_SHARED_EXECUTABLE) \
    175176        $(CSI_SHARED_EXECUTABLE) chicken-profile$(EXE) csc$(EXE) libchicken$(SO) \
  • chicken/branches/context/distribution/manifest

    r5972 r5973  
    236236Makefile.macosx
    237237Makefile.mingw
    238 Makefile.solaris
    239 Makefile.bsd
    240238Makefile.cross-linux-mingw
    241239rules.make
  • chicken/branches/context/library.scm

    r5853 r5973  
    134134     ##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
    135135     ##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
    136      ##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
     136     ##sys#intern-symbol ##sys#intern-symbol/context ##sys#make-string ##sys#number? software-type build-platform
    137137     open-output-string get-output-string print-call-chain ##sys#symbol-has-toplevel-binding? repl
    138138     argv condition-property-accessor ##sys#decorate-lambda ##sys#become! ##sys#lambda-decoration
     
    10651065(define ##sys#snafu '##sys#fnord)
    10661066(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
     1067(define ##sys#intern-symbol/context (##core#primitive "C_string_to_symbol_c"))
    10671068(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))
    10681069
     
    23902391                       (##sys#setbyte p 0 i)
    23912392                       (##sys#intern-symbol
    2392                         (string-append p (##sys#substring tok 0 i) (##sys#substring tok (fx+ i 1) toklen)) ) ]
     2393                        (string-append p (##sys#substring tok 0 i) (##sys#substring tok (fx+ i 1) toklen))) ]
    23932394                      [else (loop (fx+ i 1))] ) ) ) )
    23942395
     
    24022403                                   (char=? #\: (##core#inline "C_subchar" tok (fx- len 1)))
    24032404                                   (##sys#substring tok 0 (fx- len 1)) ) ) )
    2404                      => build-keyword]  ; ugh
     2405                     => build-keyword]
    24052406                    [(not ##sys#current-namespace) (build-symbol tok)]
    24062407                    [else
     
    24182419             (if ##sys#default-namespace-prefix
    24192420                 (##sys#string-append ##sys#default-namespace-prefix tok)
    2420                  tok) ) )
     2421                 tok)) )
    24212422         
    24222423          (define (build-keyword tok)
     
    24822483                                  (##sys#read-char-0 port)
    24832484                                  (r-namespace) (readrec) )
     2485                                 ((#\[)
     2486                                  (##sys#read-char-0 port)
     2487                                  (let* ((pn (r-token))
     2488                                         (uid (readrec)) )
     2489                                    (r-spaces)
     2490                                    (if (char=? #\] (##sys#read-char-0 port))
     2491                                        (##sys#intern-symbol/context pn uid)
     2492                                        (##sys#read-error port "missing `]' for context symbol" pn) ) ) )
    24842493                                 ((#\#)
    24852494                                  (##sys#read-char-0 port)
     
    26842693 
    26852694(define (print . args)
    2686     (*print-each args)
    2687     (##sys#write-char-0 #\newline ##sys#standard-output)
    2688     (if (null? args) (void) (car args)) )
     2695  (*print-each args)
     2696  (##sys#write-char-0 #\newline ##sys#standard-output)
     2697  (if (null? args) (void) (car args)) )
    26892698
    26902699(define (print* . args)
     
    28112820                       [(memq x '(#!optional #!key #!rest)) (outstr port (##sys#slot x 1))]
    28122821                       [else
    2813                         (let ([str (##sys#symbol->qualified-string x)])
     2822                        (let ((str (##sys#symbol->qualified-string x))
     2823                              (uid (##sys#slot x 2)) )
     2824                          (when uid (outstr port "#["))
    28142825                          (if (or (not readable) (sym-is-readable? str))
    28152826                              (outstr port str)
    2816                               (outreadablesym port str) ) ) ] ) )
     2827                              (outreadablesym port str) )
     2828                          (when uid
     2829                            (outchr port #\space)
     2830                            (out uid)
     2831                            (outchr port #\]) ) ) ] ) )
    28172832                ((##sys#number? x) (outstr port (##sys#number->string x)))
    28182833                ((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x)))
     
    44074422  (foreign-lambda c-pointer "C_find_symbol_table" c-string) )
    44084423
    4409 (define ##sys#import
    4410   (let ([enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)])
    4411     (lambda (ns  . more)
    4412       (let-optionals more ([syms '()] [prefix #f])
    4413         (let ([prefix
    4414                (and prefix
    4415                     (cond [(symbol? prefix) (##sys#slot prefix 1)]
    4416                           [(string? prefix) prefix]
    4417                           [else (##sys#signal-hook #:type-error "bad argument type - invalid prefix" prefix)] ) ) ] )
    4418           (let ([nsp (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1)))])
    4419             (define (copy s str)
    4420               (let ([s2 (##sys#intern-symbol
    4421                          (if prefix
    4422                              (##sys#string-append prefix str)
    4423                              str) ) ] )
    4424                 (##sys#setslot s2 0 (##sys#slot s 0)) ) )
    4425             (unless nsp (##sys#error "undefined namespace" ns))
    4426             (if (null? syms)
    4427                 (let ([it (cons -1 '())])
    4428                   (let loop ()
    4429                     (let ([s (enum-syms! nsp it)])
    4430                       (when s
    4431                         (copy s (##sys#slot s 1))
    4432                         (loop) ) ) ) )
    4433                 (for-each
    4434                  (lambda (ss)
    4435                    (let ([old #f]
    4436                          [new #f] )
    4437                      (if (and (pair? ss) (pair? (##sys#slot ss 1)))
    4438                          (begin
    4439                            (set! old (##sys#slot ss 0))
    4440                            (set! new (##sys#slot (##sys#slot ss 1) 0)) )
    4441                          (begin
    4442                            (set! old ss)
    4443                            (set! new ss) ) )
    4444                      (let* ([str (##sys#slot old 1)]
    4445                             [s (##sys#find-symbol str nsp)] )
    4446                        (unless s
    4447                          (##sys#error "symbol not exported from namespace" ss ns) )
    4448                        (copy s (##sys#slot new 1)) ) ) )
    4449                  syms) ) ) ) ) ) ) )
    4450 
    4451 (define (##sys#namespace-ref ns sym . default)
    4452   (let ([s (##sys#find-symbol
    4453             (cond [(symbol? sym) (##sys#slot sym 1)]
    4454                   [(string? sym) sym]
    4455                   [else (##sys#signal-hook #:type-error "bad argument type - not a valid import name" sym)] )
    4456             (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1))) ) ] )
    4457     (cond [s (##core#inline "C_retrieve" s)]
    4458           [(pair? default) (car default)]
    4459           [else (##sys#error "symbol not exported from namespace" sym ns)] ) ) )
    4460 
    44614424(define (##sys#walk-namespace proc . args)
    44624425  (let ([ns (if (pair? args) (car args) ".")])
  • chicken/branches/context/lolevel.scm

    r5861 r5973  
    474474      (let copy ([x x])
    475475        (cond [(not (##core#inline "C_blockp" x)) x]
    476               [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
     476              [(symbol? x) (##sys#intern-symbol/context (##sys#slot x 1) (##sys#slot x 2))]
    477477              [else
    478478               (let* ([n (##sys#size x)]
     
    581581
    582582(define object-size
    583     (lambda (x)
    584       (let ([tab (make-hash-table eq?)])
    585         (let evict ([x x])
    586           (cond [(not (##core#inline "C_blockp" x)) 0]
    587                 [(hash-table-ref/default tab x #f) 0]
    588                 [else
    589                 (let* ([n (##sys#size x)]
    590                         [bytes
    591                         (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
    592                               (##core#inline "C_bytes" 1) ) ] )
    593                    (hash-table-set! tab x #t)
    594                    (unless (##core#inline "C_byteblockp" x)
    595                      (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
    596                                 1
    597                                 0)
    598                              (fx+ i 1) ] )
    599                         ((fx>= i n))
    600                        (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
    601                    bytes) ] ) ) ) ) )
     583  (lambda (x)
     584    (let ([tab (make-hash-table eq?)])
     585      (let evict ([x x])
     586        (cond [(not (##core#inline "C_blockp" x)) 0]
     587              [(hash-table-ref/default tab x #f) 0]
     588              [else
     589              (let* ([n (##sys#size x)]
     590                      [bytes
     591                      (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
     592                            (##core#inline "C_bytes" 1) ) ] )
     593                 (hash-table-set! tab x #t)
     594                 (unless (##core#inline "C_byteblockp" x)
     595                   (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x))
     596                              1
     597                              0)
     598                           (fx+ i 1) ] )
     599                      ((fx>= i n))
     600                     (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
     601                 bytes) ] ) ) ) ) )
    602602
    603603(define object-unevict
    604     (lambda (x #!optional (full #f))
    605       (define (err x)
    606         (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
    607       (let ([tab (make-hash-table eq?)])
    608         (let copy ([x x])
    609           (cond [(not (##core#inline "C_blockp" x)) x]
    610                 [(not (##core#inline "C_permanentp" x)) x]
    611                 [(hash-table-ref/default tab x #f)]
    612                 [(##core#inline "C_byteblockp" x)
    613                 (if full
    614                      (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
    615                        (hash-table-set! tab x y)
    616                        y)
    617                      x) ]
    618                 [(symbol? x)
    619                  (let ([y (##sys#intern-symbol (##sys#slot x 1))])
    620                    (hash-table-set! tab x y)
    621                    y) ]
    622                 [else
    623                 (let* ([words (##sys#size x)]
    624                         [y (##core#inline "C_copy_block" x (make-vector words))] )
    625                    (hash-table-set! tab x y)
    626                    (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
    627                        ((fx>= i words))
    628                      (##sys#setslot y i (copy (##sys#slot y i))) )
    629                    y) ] ) ) ) ) )
     604  (lambda (x #!optional (full #f))
     605    (define (err x)
     606      (##sys#signal-hook #:type-error 'object-unevict "can not copy object" x) )
     607    (let ([tab (make-hash-table eq?)])
     608      (let copy ([x x])
     609        (cond [(not (##core#inline "C_blockp" x)) x]
     610              [(not (##core#inline "C_permanentp" x)) x]
     611              [(hash-table-ref/default tab x #f)]
     612              [(##core#inline "C_byteblockp" x)
     613              (if full
     614                   (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
     615                     (hash-table-set! tab x y)
     616                     y)
     617                   x) ]
     618              [(symbol? x)
     619               (let ([y (##sys#intern-symbol/context (##sys#slot x 1) (##sys#slot x 2))])
     620                 (hash-table-set! tab x y)
     621                 y) ]
     622              [else
     623              (let* ([words (##sys#size x)]
     624                      [y (##core#inline "C_copy_block" x (make-vector words))] )
     625                 (hash-table-set! tab x y)
     626                 (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
     627                     ((fx>= i words))
     628                   (##sys#setslot y i (copy (##sys#slot y i))) )
     629                 y) ] ) ) ) ) )
    630630
    631631
  • chicken/branches/context/rules.make

    r5972 r5973  
    610610# program objects
    611611
    612 chicken-profile$(O): chicken-profile.c chicken.h $(CHICKEN_CONFIG_H) libchicken$(SO)
     612chicken-profile$(O): chicken-profile.c chicken.h $(CHICKEN_CONFIG_H)
    613613        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    614614          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT_OPTION) $@
     
    680680          libchicken$(A) $(LIBRARIES)
    681681
    682 $(CSI_STATIC_EXECUTABLE): csi$(O)
     682$(CSI_STATIC_EXECUTABLE): csi$(O) libchicken$(A)
    683683        $(LINKER) $(LINKER_LINK_STATIC_OPTION) $< $(LINKER_OUTPUT_OPTION) $@ libchicken$(A) $(LIBRARIES)
    684684
  • chicken/branches/context/runtime.c

    r5932 r5973  
    492492static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm;
    493493static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
    494 static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
     494static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_word uid, C_SYMBOL_TABLE *stable);
    495495static int C_fcall hash_string(int len, C_char *str, unsigned int m) C_regparm;
    496 static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
     496static C_word C_fcall lookup(C_word key, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable) C_regparm;
    497497static double compute_symbol_table_load(double *avg_bucket_len, int *total);
    498498static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
     
    852852  void *root = CHICKEN_new_gc_root();
    853853
    854   if(C_truep(s = lookup(key, len, name, symbol_table))) {
     854  if(C_truep(s = lookup(key, len, name, C_SCHEME_FALSE, symbol_table))) {
    855855    if(C_u_i_car(s) != C_SCHEME_UNBOUND) {
    856856      CHICKEN_gc_root_set(root, s);
     
    938938  C_word s;
    939939
    940   if(C_truep(s = lookup(key, len, sptr, stable))) return s;
     940  if(C_truep(s = lookup(key, len, sptr, C_SCHEME_FALSE, stable))) return s;
    941941  else return C_SCHEME_FALSE;
    942942}
     
    18671867C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
    18681868{
     1869  return C_intern_in_c(ptr, len, str, C_SCHEME_FALSE, stable);
     1870}
     1871
     1872
     1873C_regparm C_word C_fcall C_intern_in_c(C_word **ptr, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable)
     1874{
    18691875  int key;
    18701876  C_word s;
     
    18741880  key = hash_string(len, str, stable->size);
    18751881
    1876   if(C_truep(s = lookup(key, len, str, stable))) return s;
     1882  if(C_truep(s = lookup(key, len, str, uid, stable))) return s;
    18771883
    18781884  s = C_string(ptr, len, str);
    1879   return add_symbol(ptr, key, s, stable);
     1885  return add_symbol(ptr, key, s, uid, stable);
    18801886}
    18811887
     
    18831889C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)
    18841890{
     1891  return C_h_intern_in_c(slot, len, str, C_SCHEME_FALSE, stable);
     1892}
     1893
     1894
     1895C_regparm C_word C_fcall C_h_intern_in_c(C_word *slot, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable)
     1896{
    18851897  /* Intern as usual, but remember slot, if looked up symbol is in nursery.
    1886      also: allocatein static memory. */
     1898     also: allocate in static memory. */
    18871899  int key;
    18881900  C_word s;
     
    18921904  key = hash_string(len, str, stable->size);
    18931905
    1894   if(C_truep(s = lookup(key, len, str, stable))) {
     1906  if(C_truep(s = lookup(key, len, str, uid, stable))) {
    18951907    if(C_in_stackp(s)) C_mutate(slot, s);
    18961908   
     
    18991911
    19001912  s = C_static_string(C_heaptop, len, str);
    1901   return add_symbol(C_heaptop, key, s, stable);
     1913  return add_symbol(C_heaptop, key, s, uid, stable);
    19021914}
    19031915
     
    19091921  C_word s;
    19101922
    1911   if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
     1923  if(C_truep(s = lookup(key, len, str, C_SCHEME_FALSE, symbol_table))) return s;
    19121924  else return C_SCHEME_FALSE;
    19131925}
     
    19221934  key = hash_string(len, C_c_string(str), symbol_table->size);
    19231935
    1924   return lookup(key, len, C_c_string(str), symbol_table);
     1936  return lookup(key, len, C_c_string(str), C_block_item(sym, 2), symbol_table);
    19251937}
    19261938
     
    19511963
    19521964
    1953 C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
    1954 {
    1955   C_word bucket, sym, s;
     1965C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_word uid, C_SYMBOL_TABLE *stable)
     1966{
     1967  C_word bucket, sym, s, suid;
    19561968
    19571969  for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
    19581970    sym = C_u_i_car(bucket);
    1959     s = C_u_i_cdr(sym);
    1960 
    1961     if(C_header_size(s) == (C_word)len && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
     1971    s = C_block_item(sym, 1);
     1972    suid = C_block_item(sym, 2);
     1973
     1974    if(uid == suid && C_header_size(s) == (C_word)len && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
    19621975      return sym;
    19631976  }
     
    19962009
    19972010
    1998 C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)
     2011C_word add_symbol(C_word **ptr, C_word key, C_word string, C_word uid, C_SYMBOL_TABLE *stable)
    19992012{
    20002013  C_word bucket, sym, b2, *p;
     
    20072020  C_set_block_item(sym, 0, keyw ? sym : C_SCHEME_UNBOUND); /* keyword? */
    20082021  C_set_block_item(sym, 1, string);
     2022  C_set_block_item(sym, 2, uid);
    20092023#ifdef C_EXTRA_SYMBOL_SLOT
    2010   C_set_block_item(sym, 2, C_SCHEME_UNDEFINED);
     2024  C_set_block_item(sym, 3, C_SCHEME_UNDEFINED);
    20112025#endif
    20122026  *ptr = p;
     
    71377151void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string)
    71387152{
     7153  C_string_to_symbol_c(c + 1, closure, k, string, C_SCHEME_FALSE);
     7154}
     7155
     7156
     7157void C_ccall C_string_to_symbol_c(C_word c, C_word closure, C_word k, C_word string, C_word uid)
     7158{
    71397159  int len, key;
    71407160  C_word s, *a = C_alloc(6);    /* 6 <=> 1 bucket (pair) + 1 symbol */
    71417161  C_char *name;
    71427162
    7143   if(c != 3) C_bad_argc(c, 3);
     7163  if(c != 4) C_bad_argc(c, 4);
    71447164
    71457165  if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
     
    71507170  key = hash_string(len, name, symbol_table->size);
    71517171
    7152   if(!C_truep(s = lookup(key, len, name, symbol_table)))
    7153     s = add_symbol(&a, key, string, symbol_table);
     7172  if(!C_truep(s = lookup(key, len, name, uid, symbol_table)))
     7173    s = add_symbol(&a, key, string, uid, symbol_table);
    71547174
    71557175  C_kontinue(k, s);
Note: See TracChangeset for help on using the changeset viewer.