Changeset 36241 in project


Ignore:
Timestamp:
08/13/18 00:26:13 (2 months ago)
Author:
kon
Message:

split symbol-table-access into own module, rel 3.2.0

Location:
release/5/apropos
Files:
2 added
4 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/5/apropos/tags/3.2.0/apropos-api.scm

    r36212 r36241  
    2323;; attempts to hide this fact.
    2424
    25 #>
    26 /*special stuff from the runtime & scheme API*/
    27 #define ROOT_SYMBOL_TABLE_NAME  "."
    28 
    29 #define raw_symbol_table_size( stable )       ((stable)->size)
    30 #define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
    31 
    32 #define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
    33 #define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
    34 
    35 static C_regparm C_SYMBOL_TABLE *
    36 find_root_symbol_table()
    37 {
    38   return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
    39 }
    40 
    41 static C_regparm C_SYMBOL_TABLE *
    42 remember_root_symbol_table()
    43 {
    44   static C_SYMBOL_TABLE *root_symbol_table = NULL;
    45   if(!root_symbol_table) {
    46     root_symbol_table = find_root_symbol_table();
    47   }
    48 
    49   return root_symbol_table;
    50 }
    51 
    52 //FIXME root_symbol_table re-allocated?
    53 //#define use_root_symbol_table   find_root_symbol_table
    54 #define use_root_symbol_table    remember_root_symbol_table
    55 <#
    56 
    5725(declare
    5826  (bound-to-procedure
    59     ##sys#fast-reverse
    6027    ##sys#symbol-has-toplevel-binding?
    6128    ##sys#macro-environment
     
    6633
    6734(;export
    68   ;
    6935  check-apropos-number-base
    70   ;
    7136  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
    72   ;
    7337  apropos-default-base apropos-interning apropos-default-options
    74   ;Original
    75   apropos apropos-list apropos-information-list
    76   ;Crispy
    77   ;apropos/environment apropos-list/environment apropos-information-list/environment
    78   ;Extra Crispy
    79   ;apropos/environments apropos-list/environments apropos-information-list/environments
    80 )
     38  apropos apropos-list apropos-information-list)
    8139
    8240(import scheme
     
    10866  (only symbol-qualified-utils qualified-symbol?)
    10967  (only type-checks check-fixnum define-check+error-type)
    110   (only type-errors define-error-type error-argument-type))
     68  (only type-errors define-error-type error-argument-type)
     69  symbol-table-access)
    11170
    11271;;; Support
     
    249208    ;
    250209    (values mod nam) ) )
    251 
    252 ;; Symbol Table
    253 
    254 (: root-symbol-table-size (--> fixnum))
    255 ;
    256 (define root-symbol-table-size
    257   (foreign-lambda* int ()
    258     "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )
    259 
    260 (: root-symbol-table-element (fixnum --> pair))
    261 ;
    262 (define root-symbol-table-element
    263   (foreign-lambda* scheme-object ((int i))
    264     "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
    265 
    266 (: bucket-symbol (pair --> symbol))
    267 ;
    268 (define bucket-symbol
    269   (foreign-lambda* scheme-object ((scheme-object bucket))
    270     "C_return( raw_bucket_symbol( bucket ) );"))
    271 
    272 (: bucket-link (pair --> list))
    273 ;
    274 (define bucket-link
    275   (foreign-lambda* scheme-object ((scheme-object bucket))
    276     "C_return( raw_bucket_link( bucket ) );"))
    277 
    278 (: bucket-last? (list --> boolean))
    279 ;
    280 (define bucket-last? null?)
    281 
    282 ;;
    283 
    284 (define-type <symbol-table-cursor> (or boolean pair))
    285 
    286 (: make-symbol-table-cursor (* * --> <symbol-table-cursor>))
    287 ;
    288 (define make-symbol-table-cursor cons)
    289 
    290 (: symbol-table-cursor-active? (* --> boolean))
    291 ;
    292 (define symbol-table-cursor-active? pair?)
    293 
    294 (: symbol-table-cursor? (* --> boolean))
    295 ;
    296 (define (symbol-table-cursor? obj)
    297   (or
    298     (not obj)
    299     (symbol-table-cursor-active? obj)) )
    300 
    301 (: symbol-table-cursor-index (<symbol-table-cursor> --> *))
    302 ;
    303 (define symbol-table-cursor-index car)
    304 
    305 (: set-symbol-table-cursor-index! (<symbol-table-cursor> * -> void))
    306 ;
    307 (define set-symbol-table-cursor-index! set-car!)
    308 
    309 (: symbol-table-cursor-bucket (<symbol-table-cursor> --> *))
    310 ;
    311 (define symbol-table-cursor-bucket cdr)
    312 
    313 (: set-symbol-table-cursor-bucket! (<symbol-table-cursor> * -> void))
    314 ;
    315 (define set-symbol-table-cursor-bucket! set-cdr!)
    316 
    317 (: symbol-table-cursor (--> <symbol-table-cursor>))
    318 ;
    319 (define (symbol-table-cursor)
    320   (make-symbol-table-cursor -1 '()) )
    321 
    322 ;;
    323 
    324 (: next-root-symbol (<symbol-table-cursor> --> <symbol-table-cursor>))
    325 ;
    326 (define (next-root-symbol cursor)
    327   (and
    328     (symbol-table-cursor-active? cursor)
    329     (let loop (
    330       (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
    331       (idx (symbol-table-cursor-index cursor)))
    332       ;gotta bucket ?
    333       (if (and bkt (not (bucket-last? bkt)))
    334         ;then found something => where we are
    335         (make-symbol-table-cursor idx bkt)
    336         ;else try next hash-root slot
    337         (let ((idx (fx+ 1 idx)))
    338           (and
    339             ;more to go ?
    340             (< idx (root-symbol-table-size))
    341             ;this slot
    342             (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
    343 
    344 (: initial-symbol-table-cursor (--> <symbol-table-cursor>))
    345 ;
    346 (define (initial-symbol-table-cursor)
    347   (next-root-symbol (symbol-table-cursor)) )
    348 
    349 (: root-symbol (<symbol-table-cursor> --> (or boolean symbol)))
    350 ;
    351 (define (root-symbol cursor)
    352   (and
    353     (symbol-table-cursor-active? cursor)
    354     (bucket-symbol-ref (symbol-table-cursor-bucket cursor)) ) )
    355 
    356 (: bucket-symbol-ref (list --> (or boolean symbol)))
    357 ;
    358 (define (bucket-symbol-ref bkt)
    359   (and
    360     (not (bucket-last? bkt))
    361     (bucket-symbol bkt) ) )
    362 
    363 (: bucket-link-ref (list --> (or boolean list)))
    364 ;
    365 (define (bucket-link-ref bkt)
    366   (and
    367     (not (bucket-last? bkt))
    368     (bucket-link bkt)) )
    369210
    370211;; Environments
     
    1050891
    1051892#| ;UNSUPPORTED ;FIXME case-insensitive support
     893(export
     894  ;Crispy
     895  apropos/environment apropos-list/environment apropos-information-list/environment
     896  ;Extra Crispy
     897  apropos/environments apropos-list/environments apropos-information-list/environments)
    1052898
    1053899;; Crispy
  • release/5/apropos/tags/3.2.0/apropos.egg

    r36212 r36241  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.1.2")
     5 (version "3.2.0")
    66 (category misc)
    77 (author "[[kon lovett]]")
     
    1515 (test-dependencies test)
    1616 (components
     17  (extension symbol-table-access
     18    #;(inline-file)
     19    (types-file)
     20    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1721  (extension apropos-api
    1822    #;(inline-file)
    1923    (types-file)
     24    (component-dependencies symbol-table-access)
    2025    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    2126  (extension apropos-csi
  • release/5/apropos/trunk/apropos-api.scm

    r36212 r36241  
    2323;; attempts to hide this fact.
    2424
    25 #>
    26 /*special stuff from the runtime & scheme API*/
    27 #define ROOT_SYMBOL_TABLE_NAME  "."
    28 
    29 #define raw_symbol_table_size( stable )       ((stable)->size)
    30 #define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
    31 
    32 #define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
    33 #define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
    34 
    35 static C_regparm C_SYMBOL_TABLE *
    36 find_root_symbol_table()
    37 {
    38   return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
    39 }
    40 
    41 static C_regparm C_SYMBOL_TABLE *
    42 remember_root_symbol_table()
    43 {
    44   static C_SYMBOL_TABLE *root_symbol_table = NULL;
    45   if(!root_symbol_table) {
    46     root_symbol_table = find_root_symbol_table();
    47   }
    48 
    49   return root_symbol_table;
    50 }
    51 
    52 //FIXME root_symbol_table re-allocated?
    53 //#define use_root_symbol_table   find_root_symbol_table
    54 #define use_root_symbol_table    remember_root_symbol_table
    55 <#
    56 
    5725(declare
    5826  (bound-to-procedure
    59     ##sys#fast-reverse
    6027    ##sys#symbol-has-toplevel-binding?
    6128    ##sys#macro-environment
     
    6633
    6734(;export
    68   ;
    6935  check-apropos-number-base
    70   ;
    7136  apropos-sort-key? check-apropos-sort-key error-apropos-sort-key
    72   ;
    7337  apropos-default-base apropos-interning apropos-default-options
    74   ;Original
    75   apropos apropos-list apropos-information-list
    76   ;Crispy
    77   ;apropos/environment apropos-list/environment apropos-information-list/environment
    78   ;Extra Crispy
    79   ;apropos/environments apropos-list/environments apropos-information-list/environments
    80 )
     38  apropos apropos-list apropos-information-list)
    8139
    8240(import scheme
     
    10866  (only symbol-qualified-utils qualified-symbol?)
    10967  (only type-checks check-fixnum define-check+error-type)
    110   (only type-errors define-error-type error-argument-type))
     68  (only type-errors define-error-type error-argument-type)
     69  symbol-table-access)
    11170
    11271;;; Support
     
    249208    ;
    250209    (values mod nam) ) )
    251 
    252 ;; Symbol Table
    253 
    254 (: root-symbol-table-size (--> fixnum))
    255 ;
    256 (define root-symbol-table-size
    257   (foreign-lambda* int ()
    258     "C_return( raw_symbol_table_size( use_root_symbol_table() ) );") )
    259 
    260 (: root-symbol-table-element (fixnum --> pair))
    261 ;
    262 (define root-symbol-table-element
    263   (foreign-lambda* scheme-object ((int i))
    264     "C_return( raw_symbol_table_chain( use_root_symbol_table(), i ) );") )
    265 
    266 (: bucket-symbol (pair --> symbol))
    267 ;
    268 (define bucket-symbol
    269   (foreign-lambda* scheme-object ((scheme-object bucket))
    270     "C_return( raw_bucket_symbol( bucket ) );"))
    271 
    272 (: bucket-link (pair --> list))
    273 ;
    274 (define bucket-link
    275   (foreign-lambda* scheme-object ((scheme-object bucket))
    276     "C_return( raw_bucket_link( bucket ) );"))
    277 
    278 (: bucket-last? (list --> boolean))
    279 ;
    280 (define bucket-last? null?)
    281 
    282 ;;
    283 
    284 (define-type <symbol-table-cursor> (or boolean pair))
    285 
    286 (: make-symbol-table-cursor (* * --> <symbol-table-cursor>))
    287 ;
    288 (define make-symbol-table-cursor cons)
    289 
    290 (: symbol-table-cursor-active? (* --> boolean))
    291 ;
    292 (define symbol-table-cursor-active? pair?)
    293 
    294 (: symbol-table-cursor? (* --> boolean))
    295 ;
    296 (define (symbol-table-cursor? obj)
    297   (or
    298     (not obj)
    299     (symbol-table-cursor-active? obj)) )
    300 
    301 (: symbol-table-cursor-index (<symbol-table-cursor> --> *))
    302 ;
    303 (define symbol-table-cursor-index car)
    304 
    305 (: set-symbol-table-cursor-index! (<symbol-table-cursor> * -> void))
    306 ;
    307 (define set-symbol-table-cursor-index! set-car!)
    308 
    309 (: symbol-table-cursor-bucket (<symbol-table-cursor> --> *))
    310 ;
    311 (define symbol-table-cursor-bucket cdr)
    312 
    313 (: set-symbol-table-cursor-bucket! (<symbol-table-cursor> * -> void))
    314 ;
    315 (define set-symbol-table-cursor-bucket! set-cdr!)
    316 
    317 (: symbol-table-cursor (--> <symbol-table-cursor>))
    318 ;
    319 (define (symbol-table-cursor)
    320   (make-symbol-table-cursor -1 '()) )
    321 
    322 ;;
    323 
    324 (: next-root-symbol (<symbol-table-cursor> --> <symbol-table-cursor>))
    325 ;
    326 (define (next-root-symbol cursor)
    327   (and
    328     (symbol-table-cursor-active? cursor)
    329     (let loop (
    330       (bkt (bucket-link-ref (symbol-table-cursor-bucket cursor)))
    331       (idx (symbol-table-cursor-index cursor)))
    332       ;gotta bucket ?
    333       (if (and bkt (not (bucket-last? bkt)))
    334         ;then found something => where we are
    335         (make-symbol-table-cursor idx bkt)
    336         ;else try next hash-root slot
    337         (let ((idx (fx+ 1 idx)))
    338           (and
    339             ;more to go ?
    340             (< idx (root-symbol-table-size))
    341             ;this slot
    342             (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
    343 
    344 (: initial-symbol-table-cursor (--> <symbol-table-cursor>))
    345 ;
    346 (define (initial-symbol-table-cursor)
    347   (next-root-symbol (symbol-table-cursor)) )
    348 
    349 (: root-symbol (<symbol-table-cursor> --> (or boolean symbol)))
    350 ;
    351 (define (root-symbol cursor)
    352   (and
    353     (symbol-table-cursor-active? cursor)
    354     (bucket-symbol-ref (symbol-table-cursor-bucket cursor)) ) )
    355 
    356 (: bucket-symbol-ref (list --> (or boolean symbol)))
    357 ;
    358 (define (bucket-symbol-ref bkt)
    359   (and
    360     (not (bucket-last? bkt))
    361     (bucket-symbol bkt) ) )
    362 
    363 (: bucket-link-ref (list --> (or boolean list)))
    364 ;
    365 (define (bucket-link-ref bkt)
    366   (and
    367     (not (bucket-last? bkt))
    368     (bucket-link bkt)) )
    369210
    370211;; Environments
     
    1050891
    1051892#| ;UNSUPPORTED ;FIXME case-insensitive support
     893(export
     894  ;Crispy
     895  apropos/environment apropos-list/environment apropos-information-list/environment
     896  ;Extra Crispy
     897  apropos/environments apropos-list/environments apropos-information-list/environments)
    1052898
    1053899;; Crispy
  • release/5/apropos/trunk/apropos.egg

    r36212 r36241  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.1.2")
     5 (version "3.2.0")
    66 (category misc)
    77 (author "[[kon lovett]]")
     
    1515 (test-dependencies test)
    1616 (components
     17  (extension symbol-table-access
     18    #;(inline-file)
     19    (types-file)
     20    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    1721  (extension apropos-api
    1822    #;(inline-file)
    1923    (types-file)
     24    (component-dependencies symbol-table-access)
    2025    (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
    2126  (extension apropos-csi
Note: See TracChangeset for help on using the changeset viewer.