Changeset 36149 in project


Ignore:
Timestamp:
08/11/18 17:13:49 (13 months ago)
Author:
Kon Lovett
Message:

fix off-by-2 when modules in list but sym is toplevel (now +2 when no mods in list), update doc

Location:
release/5/apropos
Files:
6 edited
1 copied

Legend:

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

    r36031 r36149  
    77;; Issues
    88;;
     9;; - too much padding (+2) when no module names in list
     10;;
    911;; - Use of 'global-symbol' routines is just wrong when an
    1012;; evaluation-environment (##sys#environment?) is not the
     
    2022;; for any syntactic keywords from the R5RS. The public API of 'apropos'
    2123;; attempts to hide this fact.
     24
     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
     35static C_regparm C_SYMBOL_TABLE *
     36find_root_symbol_table()
     37{
     38  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
     39}
     40
     41static C_regparm C_SYMBOL_TABLE *
     42remember_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<#
    2256
    2357(declare
     
    217251    (values mod nam) ) )
    218252
    219 ;; special stuff from the runtime & scheme API
    220 
    221 #>
    222 #define ROOT_SYMBOL_TABLE_NAME  "."
    223 
    224 #define raw_symbol_table_size( stable )       ((stable)->size)
    225 #define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
    226 
    227 #define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
    228 #define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
    229 
    230 static C_regparm C_SYMBOL_TABLE *
    231 find_root_symbol_table()
    232 {
    233   return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
    234 }
    235 
    236 static C_regparm C_SYMBOL_TABLE *
    237 remember_root_symbol_table()
    238 {
    239   static C_SYMBOL_TABLE *root_symbol_table = NULL;
    240   if(!root_symbol_table) {
    241     root_symbol_table = find_root_symbol_table();
    242   }
    243 
    244   return root_symbol_table;
    245 }
    246 
    247 //FIXME root_symbol_table re-allocated?
    248 //#define use_root_symbol_table   find_root_symbol_table
    249 #define use_root_symbol_table    remember_root_symbol_table
    250 <#
     253;; Symbol Table
    251254
    252255(: root-symbol-table-size (--> fixnum))
     
    317320(define (symbol-table-cursor)
    318321  (make-symbol-table-cursor -1 '()) )
    319 
    320 ;;
    321 
    322 (: search-interaction-environment-symbols (* procedure --> list))
    323 ;
    324 (define (search-interaction-environment-symbols env optarg?)
    325   (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
    326     (let ((sym (root-symbol cursor)))
    327       (if (not sym)
    328         syms
    329         (let ((syms (if (optarg? sym) (cons sym syms) syms)))
    330           (loop (next-root-symbol cursor) syms) ) ) ) ) )
    331 
    332 (: search-list-environment-symbols (list procedure --> list))
    333 ;
    334 (define (search-list-environment-symbols env optarg?)
    335   (foldl
    336     (lambda (syms cell)
    337       (let ((sym (car cell)))
    338         (if (optarg? sym)
    339           (cons sym syms)
    340           syms ) ) )
    341     '()
    342     env) )
    343 
    344 (: search-macro-environment-symbols (list procedure --> list))
    345 ;
    346 (define (search-macro-environment-symbols env optarg?)
    347   (search-list-environment-symbols env optarg?) )
    348 
    349 (: search-system-environment-symbols (list procedure --> list))
    350 ;
    351 (define (search-system-environment-symbols env optarg?)
    352   (if env
    353     (search-list-environment-symbols env optarg?)
    354     (search-interaction-environment-symbols env optarg?) ) )
    355322
    356323;;
     
    402369    (bucket-link bkt)) )
    403370
    404 ;;
     371;; Environments
     372
     373(: search-interaction-environment-symbols (* procedure --> list))
     374;
     375(define (search-interaction-environment-symbols env optarg?)
     376  (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
     377    (let ((sym (root-symbol cursor)))
     378      (if (not sym)
     379        syms
     380        (let ((syms (if (optarg? sym) (cons sym syms) syms)))
     381          (loop (next-root-symbol cursor) syms) ) ) ) ) )
     382
     383(: search-list-environment-symbols (list procedure --> list))
     384;
     385(define (search-list-environment-symbols env optarg?)
     386  (foldl
     387    (lambda (syms cell)
     388      (let ((sym (car cell)))
     389        (if (optarg? sym)
     390          (cons sym syms)
     391          syms ) ) )
     392    '()
     393    env) )
     394
     395(: search-macro-environment-symbols (list procedure --> list))
     396;
     397(define (search-macro-environment-symbols env optarg?)
     398  (search-list-environment-symbols env optarg?) )
     399
     400(: search-system-environment-symbols (list procedure --> list))
     401;
     402(define (search-system-environment-symbols env optarg?)
     403  (if env
     404    (search-list-environment-symbols env optarg?)
     405    (search-interaction-environment-symbols env optarg?) ) )
    405406
    406407;;
     
    959960    (fx- maxsymlen maxlen) ) )
    960961
     962;FIXME need to know if ANY mods, then no mod pad needed (has +2)
    961963(define (display-apropos isyms macenv sort-key raw?)
    962964  ;
     
    982984        ;
    983985        (if (eq? TOPLEVEL-MODULE-SYMBOL mod)
    984           (display (make-string+ mod-padlen))
     986          (display (make-string+ (fx+ 2 mod-padlen)))
    985987          (begin
    986988            (display mod)
  • release/5/apropos/tags/3.1.1/apropos-csi.scm

    r36031 r36149  
    3131;;; Support
    3232
    33 ;;; File Utilities
    34 
    35 (define (read-file #!optional (port ##sys#standard-input) (reader read) max)
    36   ;
    37   (define (slurp port)
    38     (do ((x (reader port) (reader port))
    39          (i 0 (fx+ i 1))
    40          (xs '() (cons x xs)) )
    41       ((or (eof-object? x) (and max (fx>= i max))) (##sys#fast-reverse xs)) ) )
    42   ;
    43   (if (port? port)
    44     (slurp port)
    45           (call-with-input-file port slurp) ) )
    46 
    4733;; string extensions
    4834
     
    7864 The quoted PATT:
    7965
    80    '(PATT . PATT):
    81 
    82       '(PATT . _) is a synonym for `PATT split module`.
    83 
    84       '(_ . PATT) is a synonym for `PATT split name`.
    85 
    86       '(_ . _) is a synonym for `(: (* any))` or match any.
    87 
    88       '(PATT . PATT) performs as if `PATT+PATT split module+name` worked.
     66    '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
     67    '(PATT . _)     synonym for `PATT split module`.
     68    '(_ . PATT)     synonym for `PATT split name`.
     69    '(_ . _)        synonym for `(: (* any))` or match any.
    8970
    9071  '<atom>
     
    11899(define (interp-split-arg loc arg)
    119100  (case arg
    120     ((n nam name)
    121       #:name )
    122     ((m mod module)
    123       #:module )
     101    ((n nam name)     #:name )
     102    ((m mod module)   #:module )
    124103    (else
    125104      (if (not arg)
     
    129108(define (interp-sort-arg loc arg)
    130109  (case arg
    131     ((n nam name)
    132       #:name )
    133     ((m mod module)
    134       #:module )
    135     ((t typ type)
    136       #:type )
     110    ((n nam name)     #:name )
     111    ((m mod module)   #:module )
     112    ((t typ type)     #:type )
    137113    (else
    138114      (if (not arg)
     
    223199  (let* (
    224200    (cmdlin (read-line))
    225     (args (with-input-from-string cmdlin read-file))
     201    (args (with-input-from-string cmdlin read-list))
    226202    (apropos-args (parse-csi-apropos-arguments args)) )
    227203    ;NOTE will not dump the symbol-table unless explicit ; use '(: (* any))
  • release/5/apropos/tags/3.1.1/apropos.egg

    r36031 r36149  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.1.0")
     5 (version "3.1.1")
    66 (category misc)
    77 (author "[[kon lovett]]")
  • release/5/apropos/trunk/apropos-api.scm

    r36031 r36149  
    77;; Issues
    88;;
     9;; - too much padding (+2) when no module names in list
     10;;
    911;; - Use of 'global-symbol' routines is just wrong when an
    1012;; evaluation-environment (##sys#environment?) is not the
     
    2022;; for any syntactic keywords from the R5RS. The public API of 'apropos'
    2123;; attempts to hide this fact.
     24
     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
     35static C_regparm C_SYMBOL_TABLE *
     36find_root_symbol_table()
     37{
     38  return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
     39}
     40
     41static C_regparm C_SYMBOL_TABLE *
     42remember_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<#
    2256
    2357(declare
     
    217251    (values mod nam) ) )
    218252
    219 ;; special stuff from the runtime & scheme API
    220 
    221 #>
    222 #define ROOT_SYMBOL_TABLE_NAME  "."
    223 
    224 #define raw_symbol_table_size( stable )       ((stable)->size)
    225 #define raw_symbol_table_chain( stable, i )   ((stable)->table[ (i) ])
    226 
    227 #define raw_bucket_symbol( bucket )   (C_block_item( (bucket), 0 ))
    228 #define raw_bucket_link( bucket )     (C_block_item( (bucket), 1 ))
    229 
    230 static C_regparm C_SYMBOL_TABLE *
    231 find_root_symbol_table()
    232 {
    233   return C_find_symbol_table( ROOT_SYMBOL_TABLE_NAME );
    234 }
    235 
    236 static C_regparm C_SYMBOL_TABLE *
    237 remember_root_symbol_table()
    238 {
    239   static C_SYMBOL_TABLE *root_symbol_table = NULL;
    240   if(!root_symbol_table) {
    241     root_symbol_table = find_root_symbol_table();
    242   }
    243 
    244   return root_symbol_table;
    245 }
    246 
    247 //FIXME root_symbol_table re-allocated?
    248 //#define use_root_symbol_table   find_root_symbol_table
    249 #define use_root_symbol_table    remember_root_symbol_table
    250 <#
     253;; Symbol Table
    251254
    252255(: root-symbol-table-size (--> fixnum))
     
    317320(define (symbol-table-cursor)
    318321  (make-symbol-table-cursor -1 '()) )
    319 
    320 ;;
    321 
    322 (: search-interaction-environment-symbols (* procedure --> list))
    323 ;
    324 (define (search-interaction-environment-symbols env optarg?)
    325   (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
    326     (let ((sym (root-symbol cursor)))
    327       (if (not sym)
    328         syms
    329         (let ((syms (if (optarg? sym) (cons sym syms) syms)))
    330           (loop (next-root-symbol cursor) syms) ) ) ) ) )
    331 
    332 (: search-list-environment-symbols (list procedure --> list))
    333 ;
    334 (define (search-list-environment-symbols env optarg?)
    335   (foldl
    336     (lambda (syms cell)
    337       (let ((sym (car cell)))
    338         (if (optarg? sym)
    339           (cons sym syms)
    340           syms ) ) )
    341     '()
    342     env) )
    343 
    344 (: search-macro-environment-symbols (list procedure --> list))
    345 ;
    346 (define (search-macro-environment-symbols env optarg?)
    347   (search-list-environment-symbols env optarg?) )
    348 
    349 (: search-system-environment-symbols (list procedure --> list))
    350 ;
    351 (define (search-system-environment-symbols env optarg?)
    352   (if env
    353     (search-list-environment-symbols env optarg?)
    354     (search-interaction-environment-symbols env optarg?) ) )
    355322
    356323;;
     
    402369    (bucket-link bkt)) )
    403370
    404 ;;
     371;; Environments
     372
     373(: search-interaction-environment-symbols (* procedure --> list))
     374;
     375(define (search-interaction-environment-symbols env optarg?)
     376  (let loop ((cursor (initial-symbol-table-cursor)) (syms '()))
     377    (let ((sym (root-symbol cursor)))
     378      (if (not sym)
     379        syms
     380        (let ((syms (if (optarg? sym) (cons sym syms) syms)))
     381          (loop (next-root-symbol cursor) syms) ) ) ) ) )
     382
     383(: search-list-environment-symbols (list procedure --> list))
     384;
     385(define (search-list-environment-symbols env optarg?)
     386  (foldl
     387    (lambda (syms cell)
     388      (let ((sym (car cell)))
     389        (if (optarg? sym)
     390          (cons sym syms)
     391          syms ) ) )
     392    '()
     393    env) )
     394
     395(: search-macro-environment-symbols (list procedure --> list))
     396;
     397(define (search-macro-environment-symbols env optarg?)
     398  (search-list-environment-symbols env optarg?) )
     399
     400(: search-system-environment-symbols (list procedure --> list))
     401;
     402(define (search-system-environment-symbols env optarg?)
     403  (if env
     404    (search-list-environment-symbols env optarg?)
     405    (search-interaction-environment-symbols env optarg?) ) )
    405406
    406407;;
     
    959960    (fx- maxsymlen maxlen) ) )
    960961
     962;FIXME need to know if ANY mods, then no mod pad needed (has +2)
    961963(define (display-apropos isyms macenv sort-key raw?)
    962964  ;
     
    982984        ;
    983985        (if (eq? TOPLEVEL-MODULE-SYMBOL mod)
    984           (display (make-string+ mod-padlen))
     986          (display (make-string+ (fx+ 2 mod-padlen)))
    985987          (begin
    986988            (display mod)
  • release/5/apropos/trunk/apropos-csi.scm

    r36031 r36149  
    3131;;; Support
    3232
    33 ;;; File Utilities
    34 
    35 (define (read-file #!optional (port ##sys#standard-input) (reader read) max)
    36   ;
    37   (define (slurp port)
    38     (do ((x (reader port) (reader port))
    39          (i 0 (fx+ i 1))
    40          (xs '() (cons x xs)) )
    41       ((or (eof-object? x) (and max (fx>= i max))) (##sys#fast-reverse xs)) ) )
    42   ;
    43   (if (port? port)
    44     (slurp port)
    45           (call-with-input-file port slurp) ) )
    46 
    4733;; string extensions
    4834
     
    7864 The quoted PATT:
    7965
    80    '(PATT . PATT):
    81 
    82       '(PATT . _) is a synonym for `PATT split module`.
    83 
    84       '(_ . PATT) is a synonym for `PATT split name`.
    85 
    86       '(_ . _) is a synonym for `(: (* any))` or match any.
    87 
    88       '(PATT . PATT) performs as if `PATT+PATT split module+name` worked.
     66    '(PATT . PATT)  performs as if `PATT+PATT split module+name` worked.
     67    '(PATT . _)     synonym for `PATT split module`.
     68    '(_ . PATT)     synonym for `PATT split name`.
     69    '(_ . _)        synonym for `(: (* any))` or match any.
    8970
    9071  '<atom>
     
    11899(define (interp-split-arg loc arg)
    119100  (case arg
    120     ((n nam name)
    121       #:name )
    122     ((m mod module)
    123       #:module )
     101    ((n nam name)     #:name )
     102    ((m mod module)   #:module )
    124103    (else
    125104      (if (not arg)
     
    129108(define (interp-sort-arg loc arg)
    130109  (case arg
    131     ((n nam name)
    132       #:name )
    133     ((m mod module)
    134       #:module )
    135     ((t typ type)
    136       #:type )
     110    ((n nam name)     #:name )
     111    ((m mod module)   #:module )
     112    ((t typ type)     #:type )
    137113    (else
    138114      (if (not arg)
     
    223199  (let* (
    224200    (cmdlin (read-line))
    225     (args (with-input-from-string cmdlin read-file))
     201    (args (with-input-from-string cmdlin read-list))
    226202    (apropos-args (parse-csi-apropos-arguments args)) )
    227203    ;NOTE will not dump the symbol-table unless explicit ; use '(: (* any))
  • release/5/apropos/trunk/apropos.egg

    r36031 r36149  
    33
    44((synopsis "Chicken apropos")
    5  (version "3.1.0")
     5 (version "3.1.1")
    66 (category misc)
    77 (author "[[kon lovett]]")
Note: See TracChangeset for help on using the changeset viewer.