Changeset 13677 in project for chicken


Ignore:
Timestamp:
03/11/09 03:23:24 (11 years ago)
Author:
Kon Lovett
Message:

Moved 'apropos' out. Added routines to encapsulate information the new apropos extension needs

Location:
chicken/trunk
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/chicken.import.scm

    r13672 r13677  
    6767   delete-file
    6868   enable-warnings
     69   environment?
    6970   errno
    7071   error
  • chicken/trunk/eval.scm

    r13620 r13677  
    13411341(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
    13421342
     1343(define (##sys#environment? obj)
     1344  (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
     1345
    13431346(define ##sys#copy-env-table
    13441347  (lambda (e mff mf . args)
  • chicken/trunk/expand.scm

    r13351 r13677  
    125125(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
    126126(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
     127
     128; Workalike of '##sys#environment?' for syntactic environments
     129(define (##sys#syntactic-environment? obj)
     130  (and (list? obj)
     131       (or (null? obj)
     132           (call-with-current-continuation
     133             (lambda (return)
     134               (##sys#for-each
     135                (lambda (x)
     136                  (unless (and (pair? x) (= 3 (length x))
     137                               ;key
     138                               (symbol? (car x))
     139                               #;(##sys#syntactic-environment? (cadr x))
     140                               (procedure? (caddr x)) )
     141                    (return #f) ) )
     142                obj)
     143               #t ) ) ) ) )
     144
     145; Workalike of '##sys#environment-symbols' for syntactic environments
     146(define (##sys#syntactic-environment-symbols env pred )
     147  ;I have no effing idea at the moment if this is correct
     148  (define (walk-alias id)
     149    (let loop ((alias (##sys#get id '##core#macro-alias)))
     150      (and alias
     151           (or (##sys#get id '##core#real-name)
     152               (if (symbol? alias) alias
     153                   (and-let* ((env (car alias))
     154                              ((not (null? env))))
     155                     (loop (lookup id env)) ) ) ) ) ) )
     156  (let ((syms '()))
     157    (##sys#for-each
     158     (lambda (cell)
     159       (let ((id (car cell)))
     160         (cond ((pred id)
     161                (set! syms (cons id syms)) )
     162               ((walk-alias id) =>
     163                (lambda (name)
     164                  (when (pred name) (set! syms (cons name syms))) ) ) ) ) )
     165     env)
     166   syms ) )
    127167
    128168(define (##sys#extend-macro-environment name se handler)
  • chicken/trunk/files.scm

    r12937 r13677  
    5050      ##sys#windows-platform)
    5151    (bound-to-procedure
    52       string-search string-match regexp regexp-escape
    53       ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
    54       ##sys#hash-table-for-each ##sys#macro-environment
    55       ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
    56       for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
    57       decompose-pathname absolute-pathname? string-append ##sys#substring
    58       delete-file system)
     52      string-match regexp
     53      ##sys#string-append ##sys#substring  string-append
     54      getenv
     55      file-exists? delete-file
     56      call-with-output-file read-string)
    5957    (no-procedure-checks-for-usual-bindings)
    6058    (no-bound-checks))] )
  • chicken/trunk/manual/Unit utils

    r11646 r13677  
    55== Unit utils
    66
    7 This unit contains apropos and functions as a "grab bag" of procedures
    8 without a good home, and which don't have to be available by default
    9 (as compared to the [[Unit extras|extras]] unit).
     7This unit contains a "grab bag" of procedures without a good home, and which
     8don't have to be available by default (as compared to the [[Unit
     9extras|extras]] unit).
    1010
    11 This unit uses the {{extras}} and {{regex}} units.
     11This unit uses the {{extras}} and {{srfi-13}} units.
    1212
    1313
    14 === Environment Query
     14=== Executing shell commands with formatstring and error checking
    1515
    16 ==== apropos
     16==== system*
    1717
    18  [procedure] (apropos SYMBOL-PATTERN [ENVIRONMENT] [#:MACROS?])
     18 [procedure] (system* FORMATSTRING ARGUMENT1 ...)
    1919
    20 Displays symbols & type matching {{SYMBOL-PATTERN}} in the {{ENVIRONMENT}} on the {{(current-output-port)}}.
    21 
    22 ; {{SYMBOL-PATTERN}} : A symbol, string, or regex. When symbol or string substring matching is performed.
    23 ; {{ENVIRONMENT}} : An environment. When missing the {{(interaction-environment)}} is assumed.
    24 ; {{#:MACROS?}} : Keyword argument. A boolean. Include macro symbols? When missing {{#f}} is assumed.
    25 
    26 ==== apropos-list
    27 
    28  [procedure] (apropos-list SYMBOL-PATTERN [ENVIRONMENT] [#:MACROS?])
    29 
    30 Like {{apropos}} but returns a list of matching symbols.
    31 
    32 
    33 === Pathname operations
    34 
    35 ==== absolute-pathname?
    36 
    37  [procedure] (absolute-pathname? PATHNAME)
    38 
    39 Returns {{#t}} if the string {{PATHNAME}} names an absolute
    40 pathname, and returns {{#f}} otherwise.
    41 
    42 ==== decompose-pathname
    43 
    44  [procedure] (decompose-pathname PATHNAME)
    45 
    46 Returns three values: the directory-, filename- and extension-components
    47 of the file named by the string {{PATHNAME}}.
    48 For any component that is not contained in {{PATHNAME}}, {{#f}} is returned.
    49 
    50 ==== make-pathname
    51 ==== make-absolute-pathname
    52 
    53  [procedure] (make-pathname DIRECTORY FILENAME [EXTENSION [SEPARATOR]])
    54  [procedure] (make-absolute-pathname DIRECTORY FILENAME [EXTENSION [SEPARATOR]])
    55 
    56 Returns a string that names the file with the
    57 components {{DIRECTORY, FILENAME}} and (optionally)
    58 {{EXTENSION}} with {{SEPARATOR}} being the directory separation indicator
    59 (usually {{/}} on UNIX systems and {{\}} on Windows, defaulting to whatever
    60 platform this is running on).
    61 {{DIRECTORY}} can be {{#f}} (meaning no
    62 directory component), a string or a list of strings. {{FILENAME}}
    63 and {{EXTENSION}} should be strings or {{#f}}.
    64 {{make-absolute-pathname}} returns always an absolute pathname.
    65 
    66 ==== pathname-directory
    67 
    68  [procedure] (pathname-directory PATHNAME)
    69 
    70 ==== pathname-file
    71 
    72  [procedure] (pathname-file PATHNAME)
    73 
    74 ==== pathname-extension
    75 
    76  [procedure] (pathname-extension PATHNAME)
    77 
    78 Accessors for the components of {{PATHNAME}}. If the pathname does
    79 not contain the accessed component, then {{#f}} is returned.
    80 
    81 ==== pathname-replace-directory
    82 
    83  [procedure] (pathname-replace-directory PATHNAME DIRECTORY)
    84 
    85 ==== pathname-replace-file
    86 
    87  [procedure] (pathname-replace-file PATHNAME FILENAME)
    88 
    89 ==== pathname-replace-extension
    90 
    91  [procedure] (pathname-replace-extension PATHNAME EXTENSION)
    92 
    93 Return a new pathname with the specified component of {{PATHNAME}}
    94 replaced by a new value.
    95 
    96 ==== pathname-strip-directory
    97 
    98  [procedure] (pathname-strip-directory PATHNAME)
    99 
    100 ==== pathname-strip-extension
    101 
    102  [procedure] (pathname-strip-extension PATHNAME)
    103 
    104 Return a new pathname with the specified component of {{PATHNAME}}
    105 stripped.
    106 
    107 ==== directory-null?
    108 
    109  [procedure] (directory-null? DIRECTORY)
    110 
    111 Does the {{DIRECTORY}} consist only of path separators and the period?
    112 
    113 {{DIRECTORY}} may be a string or a list of strings.
    114 
    115 
    116 === Temporary files
    117 
    118 ==== create-temporary-file
    119 
    120  [procedure] (create-temporary-file [EXTENSION])
    121 
    122 Creates an empty temporary file and returns its pathname. If
    123 {{EXTENSION}} is not given, then {{.tmp}} is used. If the
    124 environment variable {{TMPDIR, TEMP}} or {{TMP}} is set,
    125 then the pathname names a file in that directory.
    126 
    127 
    128 === Deleting a file without signalling an error
    129 
    130 ==== delete-file*
    131 
    132  [procedure] (delete-file* FILENAME)
    133 
    134 If the file {{FILENAME}} exists, it is deleted and {{#t}}
    135 is returned.  If the file does not exist, nothing happens and {{#f}}
    136 is returned.
    137 
     20Similar to {{(system (sprintf FORMATSTRING ARGUMENT1 ...))}},
     21but signals an error if the invoked program should return a nonzero
     22exit status.
    13823
    13924=== Iterating over input lines and files
     
    16550</enscript>
    16651
    167 === Executing shell commands with formatstring and error checking
    168 
    169 ==== system*
    170 
    171  [procedure] (system* FORMATSTRING ARGUMENT1 ...)
    172 
    173 Similar to {{(system (sprintf FORMATSTRING ARGUMENT1 ...))}},
    174 but signals an error if the invoked program should return a nonzero
    175 exit status.
    176 
    17752
    17853=== Reading a file's contents
  • chicken/trunk/utils.scm

    r12937 r13677  
    2828(declare
    2929  (unit utils)
    30   (uses regex data-structures extras files srfi-13)
     30  (uses extras srfi-13)
    3131  (usual-integrations)
    3232  (fixnum)
     
    4141      ##sys#windows-platform)
    4242    (bound-to-procedure
    43       string-search string-match regexp regexp-escape
    44       ##sys#symbol-has-toplevel-binding? ##sys#environment-symbols
    45       ##sys#hash-table-for-each ##sys#macro-environment
    46       ##sys#string-append reverse port? read-string with-input-from-file command-line-arguments
    47       for-each-line ##sys#check-port read-line getenv make-pathname file-exists? call-with-output-file
    48       decompose-pathname absolute-pathname? string-append ##sys#substring
    49       delete-file system)
     43      ##sys#check-port port? read-string for-each-line read-line with-input-from-file
     44      command-line-arguments
     45      string-append
     46      system)
    5047    (no-procedure-checks-for-usual-bindings)
    5148    (no-bound-checks))] )
     
    5451
    5552(register-feature! 'utils)
    56 
    57 
    58 ;;; Environment utilities
    59 
    60 (define ##sys#apropos-interned)
    61 (define ##sys#apropos-macros)
    62 (let ([string-search string-search]
    63       [regexp regexp]
    64       [regexp-escape regexp-escape])
    65   (let ([makpat
    66          (lambda (patt)
    67            (when (symbol? patt)
    68              (set! patt (symbol->string patt)))
    69            (when (string? patt)
    70              (set! patt (regexp (regexp-escape patt))))
    71            patt)])
    72 
    73     (set! ##sys#apropos-interned
    74       (lambda (patt env)
    75         (set! patt (makpat patt))
    76         (##sys#environment-symbols env
    77           (lambda (sym)
    78             (and (string-search patt (symbol->string sym))
    79                  (##sys#symbol-has-toplevel-binding? sym) ) ) ) ) )
    80 
    81     (set! ##sys#apropos-macros
    82       (lambda (patt env) ; env is currently ignored
    83         (set! patt (makpat patt))
    84         (let ([ms '()])
    85           (for-each
    86            (lambda (a)
    87              (let ((key (car a)))
    88                (when (string-search patt (symbol->string key))
    89                  (set! ms (cons key ms)) ) ) )
    90            (##sys#macro-environment))
    91           ms ) ) ) ) )
    92 
    93 (define (##sys#apropos patt env #!optional macf)
    94   (let ([ts (##sys#apropos-interned patt env)])
    95     (if macf
    96         (##sys#append ts (##sys#apropos-macros patt env))
    97         ts ) ) )
    98 
    99 (define apropos-list)
    100 (define apropos)
    101 (let ([%apropos-list
    102         (lambda (loc patt args) ; #!optional (env (interaction-environment)) #!key macros?
    103           (let ([env (interaction-environment)]
    104                 [macros? #f])
    105             ; Handle extended lambda list optional & rest w/ keywords
    106             (let loop ([args args])
    107               (when (pair? args)
    108                 (let ([arg (car args)])
    109                   (if (eq? #:macros? arg)
    110                       (begin
    111                         (set! macros? (cadr args))
    112                         (loop (cddr args)) )
    113                       (begin
    114                         (set! env arg)
    115                         (loop (cdr args)) ) ) ) ) )
    116             (##sys#check-structure env 'environment loc)
    117             (unless (or (string? patt) (symbol? patt) (regexp? patt))
    118               (##sys#signal-hook #:type-error loc "bad argument type - not a string, symbol, or regexp" patt))
    119             (##sys#apropos patt env macros?) ) )]
    120       [disp-proc
    121         (lambda (proc labl)
    122           (let ([info (procedure-information proc)])
    123             (cond [(pair? info) (display (cons labl (cdr info)))]
    124                   [info         (display labl)]
    125                   [else         (display labl) ] ) ) ) ]
    126       [symlen
    127         (lambda (sym)
    128           (let ([len (##sys#size (##sys#symbol->qualified-string sym))])
    129             (if (keyword? sym)
    130                 (fx- len 2) ; compensate for leading '###' when only a ':' is printed
    131                 len ) ) )])
    132 
    133   (set! apropos-list
    134     (lambda (patt . rest)
    135       (%apropos-list 'apropos-list patt rest)))
    136 
    137   (set! apropos
    138     (lambda (patt . rest)
    139       (let ([ss (%apropos-list 'apropos patt rest)]
    140             [maxlen 0])
    141         (for-each
    142           (lambda (sym)
    143             (set! maxlen (fxmax maxlen (symlen sym))))
    144           ss)
    145         (for-each
    146           (lambda (sym)
    147             (display sym)
    148             (do ([i (fx- maxlen (symlen sym)) (fx- i 1)])
    149                 [(fx<= i 0)]
    150               (display #\space))
    151             (display #\space) (display #\:) (display #\space)
    152             (if (macro? sym)
    153                 ;FIXME want to display macro lambda arguments
    154                 (display 'macro)
    155                 (let ([bnd (##core#inline "C_retrieve" sym)])
    156                   (cond [(procedure? bnd)
    157                           (disp-proc bnd 'procedure)]
    158                         [else
    159                           (display 'variable)]) ) )
    160             (newline) )
    161           ss)))) )
    16253
    16354
Note: See TracChangeset for help on using the changeset viewer.