Changeset 38256 in project


Ignore:
Timestamp:
03/14/20 19:02:36 (2 weeks ago)
Author:
Kon Lovett
Message:

remove fx use, export procs & not vars

Location:
release/5/apropos/trunk
Files:
7 edited

Legend:

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

    r37884 r38256  
    3030  apropos apropos-list apropos-information-list)
    3131
    32 (import scheme
    33   (chicken base)
    34   (chicken foreign)
    35   (chicken syntax)
    36   (chicken keyword)
    37   (chicken fixnum)
    38   (chicken sort)
    39   (chicken type)
    40   (only (srfi 1) reverse! append! last-pair)
    41   (only (srfi 13)
    42     string-join
    43     string-trim-both
    44     string-contains string-contains-ci)
    45   (only (chicken irregex)
    46     sre->irregex
    47     irregex irregex?
    48     irregex-num-submatches
    49     irregex-search irregex-match
    50     irregex-match-data? irregex-match-num-submatches
    51     irregex-replace)
    52   (only memoized-string make-string+)
    53   (only symbol-name-utils
    54     symbol->keyword
    55     symbol-printname=? symbol-printname<?
    56     symbol-printname-length max-symbol-printname-length)
    57   (only type-checks check-fixnum define-check+error-type)
    58   (only type-errors define-error-type error-argument-type)
    59   symbol-environment-access
    60   symbol-access)
    61 
    62 ;;; Support
    63 
    64 ;;
    65 
    66 (define (any? x)
    67   #t )
     32(import scheme)
     33(import (chicken base))
     34(import (chicken foreign))
     35(import (chicken syntax))
     36(import (chicken keyword))
     37(import (chicken sort))
     38(import (chicken type))
     39(import (only (srfi 1) any reverse! append! last-pair))
     40(import (only (srfi 13)
     41  string-index string-join string-trim-both
     42  string-contains string-contains-ci))
     43(import (only (chicken irregex)
     44  sre->irregex irregex irregex?
     45  irregex-num-submatches irregex-search irregex-match irregex-match-data?
     46  irregex-match-num-submatches irregex-replace))
     47(import (only memoized-string make-string+))
     48(import (only symbol-name-utils
     49  symbol->keyword symbol-printname=?
     50  symbol-printname<? symbol-printname-length max-symbol-printname-length))
     51(import (only type-checks check-fixnum define-check+error-type))
     52(import (only type-errors define-error-type error-argument-type))
     53(import symbol-environment-access)
     54(import symbol-access)
     55
     56;;;
    6857
    6958;;
     
    8170    (or
    8271      (not ire)
    83       (fx=
     72      (=
    8473        (irregex-match-num-submatches mt)
    8574        (if (fixnum? ire) ire (irregex-num-submatches ire))) ) ) )
     
    151140
    152141(define (number-base? obj)
    153   (and (fixnum? obj) (fx<= 2 obj) (<= obj CHICKEN-MAXIMUM-BASE)) )
     142  (and (fixnum? obj) (<= 2 obj) (<= obj CHICKEN-MAXIMUM-BASE)) )
    154143
    155144(define *number-base-error-message*
     
    203192      '())) )
    204193
    205 ;; Argument List Parsing
     194;; Argument List Parsing & Matcher Generation
     195
     196;FIXME separate concerns
    206197
    207198(define default-environment system-current-environment)
     
    209200
    210201(define-constant ANY-SYMBOL '_)
     202
     203;(define apropos-excluded (make-parameter '() (lambda (x)
     204;  (if (list? x) x (apropos-excluded)))))
     205
     206;(apropos-excluded "chicken.internal")
    211207
    212208(define (make-apropos-matcher loc patt
     
    217213              (internal? #f))
    218214  ;
     215  ;(define excluded (apropos-excluded))
     216  ;
    219217  (define (matcher-for pred? data)
    220218    (define (check? str)
    221219      (and
     220        ;(not (any (lambda (x) (string-contains? str x)) excluded))
    222221        (or internal? (not (internal-module-name? str)))
    223222        (pred? str data) ) )
     
    525524    (str (symbol->string sym))
    526525    (idx (string-skip-right str char-set:digit))
    527     (idx (and idx (fx+ 1 idx))) )
     526    (idx (and idx (+ 1 idx))) )
    528527    ;
    529528    (cond
    530529      ((not idx)
    531530        sym )
    532       ((fx< (fx- (string-length str) idx) limit)
     531      ((< (- (string-length str) idx) limit)
    533532        sym )
    534533      (else
     
    702701  (let* (
    703702    (len (symbol-printname-length sym) )
    704     (maxlen (fxmin maxsymlen len) ) )
    705     (fx+ bias (fx- maxsymlen maxlen)) ) )
     703    (maxlen (min maxsymlen len) ) )
     704    (+ bias (- maxsymlen maxlen)) ) )
    706705
    707706;FIXME need to know if ANY mods, then no mod pad needed (has +2)
     
    723722        (sym-padlen (symbol-pad-length sym maxsymlen (if kwd? -1 0)) ) )
    724723        (display (if kwd? (symbol->keyword sym) sym))
    725         (display (make-string+ (fx+ *tab-width* sym-padlen))) )
     724        (display (make-string+ (+ *tab-width* sym-padlen))) )
    726725      ;<mod><tab>
    727726      (let* (
     
    730729        ;
    731730        (if (eq? (toplevel-module-symbol) mod)
    732           (display (make-string+ (fx+ *tab-width* mod-padlen)))
     731          (display (make-string+ (+ *tab-width* mod-padlen)))
    733732          (begin
    734733            (display mod)
    735             (display (make-string+ (fx+ *tab-width* mod-padlen))) ) ) )
     734            (display (make-string+ (+ *tab-width* mod-padlen))) ) ) )
    736735      ;<details>
    737736      (let ((dets (information-details info)))
     
    883882      (for-each
    884883        (lambda (macenv+syms)
    885           (set! i (fx+ 1 i))
     884          (set! i (add1 i))
    886885          (newline) (display "** Environment " i " **") (newline) (newline)
    887886          (display-apropos (cdr macenv+syms) (car macenv+syms) sort-key) )
  • release/5/apropos/trunk/apropos-csi.scm

    r37878 r38256  
    1515(module apropos-csi ()
    1616
    17 (import scheme
    18   (chicken base)
    19   (chicken fixnum)
    20   (chicken platform)
    21   (chicken io)
    22   (chicken port)
    23   (only (srfi 1) cons* reverse!)
    24   #; ;Warning: the following extensions are not currently installed: chicken.csi
    25   (only (chicken csi) toplevel-command)
    26   apropos-api)
     17(import scheme)
     18(import (chicken base))
     19(import (chicken platform))
     20(import (chicken io))
     21(import (chicken port))
     22(import (only (srfi 1) cons* reverse!))
     23#; ;Warning: the following extensions are not currently installed: chicken.csi
     24(import (only (chicken csi) toplevel-command))
     25(import apropos-api)
    2726
    2827;;; Bug Support
     
    3938(define (string-fixed-length x n #!optional (pad #\space) (tag "..."))
    4039  (let* (
    41     (rem (fx- n (string-length x)))
     40    (rem (- n (string-length x)))
    4241    (shorter? (positive? rem)) )
    4342    (if shorter?
    4443      (string-append x (make-string rem pad))
    45       (string-append (substring x 0 (fx- n (string-length tag))) tag) ) ) )
     44      (string-append (substring x 0 (- n (string-length tag))) tag) ) ) )
    4645
    4746;; Constants
  • release/5/apropos/trunk/apropos.egg

    r37882 r38256  
    55
    66((synopsis "CHICKEN apropos")
    7  (version "3.3.5")
     7 (version "3.4.0")
    88 (category misc)
    99 (author "[[kon lovett]]")
  • release/5/apropos/trunk/symbol-access.scm

    r37882 r38256  
    1010(;export
    1111  ;
    12   *toplevel-module-symbol*
    1312  toplevel-module-symbol
    1413  ;
     
    2019  split-prefixed-symbol)
    2120
    22 (import scheme
    23   (chicken base)
    24   (chicken fixnum)
    25   (chicken type)
    26   (only (srfi 13) string-skip string-drop string-take string-index))
     21(import scheme)
     22(import (chicken base))
     23(import (chicken type))
     24(import (only (srfi 13) string-skip string-drop string-take string-index))
     25
     26;;;
    2727
    2828;;
    2929
    30 ;FIXME need to recognize '##' special for 'exclude' list
     30(define-constant TOPLEVEL-MODULE-SYMBOL '||)
     31
     32;;
    3133
    3234(define-inline (namespace-tag-length str)
     35  ;namespaced identifier begins w/ '##'
    3336  (cond
    34     ((string-skip str #\#)
    35       => identity)
    36     (else
    37       0) ) )
     37    ((string-skip str #\#) => identity)
     38    (else                  0) ) )
    3839
    3940(define (global-symbol-name-start str)
     41  ;modulename & namespace identifier has no '#' (?)
    4042  (string-index str #\# (namespace-tag-length str)) )
    4143
     
    4446;; Toplevel Symbols
    4547
    46 (define-constant TOPLEVEL-MODULE-SYMBOL '||)
    47 
    48 (: *toplevel-module-symbol* (deprecated toplevel-module-symbol))
    49 (define *toplevel-module-symbol* TOPLEVEL-MODULE-SYMBOL)
    50 
     48(: toplevel-module-symbol (#!optional symbol -> symbol))
     49;
    5150(define toplevel-module-symbol (make-parameter TOPLEVEL-MODULE-SYMBOL (lambda (x)
    5251  (or
     
    5453    (toplevel-module-symbol)))))
    5554
    56 (define *toplevel-module-string* (symbol->string (toplevel-module-symbol)))
     55(: toplevel-module-string (-> string))
     56;
     57;symbol keyed memeoized string
     58(define toplevel-module-string
     59  (let ((+symbol+ #f) (+string+ #f))
     60    (lambda ()
     61      (if (eq? +symbol+ (toplevel-module-symbol))
     62        +string+
     63        (begin
     64          (set! +symbol+ (toplevel-module-symbol))
     65          (set! +string+ (symbol->string +symbol+))
     66          (toplevel-module-string) ) ) ) ) )
    5767
    5868;; Raw Access Renames
    5969
     70(: global-symbol-bound? (symbol -> boolean))
     71;
    6072(define (global-symbol-bound? sym) (##sys#symbol-has-toplevel-binding? sym))
    6173
     74(: global-symbol-ref (symbol -> *))
     75;
    6276(define (global-symbol-ref sym) (##sys#slot sym 0))
    6377
    6478;;
    6579
    66 (: internal-module-name? (string --> boolean))
     80(: internal-module-name? (string -> boolean))
    6781;
    6882(define (internal-module-name? str)
    6983  (not (zero? (namespace-tag-length str))) )
    7084
    71 (: split-prefixed-symbol (symbol --> string string))
     85(: split-prefixed-symbol (symbol -> string string))
     86;
    7287;=> module-name identifier-name
    7388;
     
    8095    ;module?
    8196    (if idx
    82       (values (string-take str idx) (string-drop str (fx+ 1 idx)))
    83       (values *toplevel-module-string* str) ) ) )
     97      (values (string-take str idx) (string-drop str (add1 idx)))
     98      (values (toplevel-module-string) str) ) ) )
    8499
    85100) ;module symbol-access
  • release/5/apropos/trunk/symbol-environment-access.scm

    r37880 r38256  
    2323  search-list-environment-symbols)
    2424
    25 (import scheme
    26   (chicken base)
    27   (chicken type)
    28   symbol-table-access)
     25(import scheme)
     26(import (chicken base))
     27(import (chicken type))
     28(import symbol-table-access)
    2929
    3030;;;
  • release/5/apropos/trunk/symbol-table-access.scm

    r37878 r38256  
    4141  cursor-next)
    4242
    43 (import scheme
    44   (chicken base)
    45   (chicken fixnum)
    46   (chicken foreign)
    47   (chicken type)
    48   (chicken syntax))
     43(import scheme)
     44(import (chicken base))
     45(import (chicken foreign))
     46(import (chicken type))
     47(import (chicken syntax))
    4948
    5049;; Symbol Table
     
    10099(define make-symbol-table-cursor cons)
    101100
    102 (: cursor-active? (* --> boolean))
     101(: cursor-active? (* -> boolean))
    103102;
    104103(define cursor-active? pair?)
    105104
    106 (: symbol-table-cursor? (* --> boolean))
     105(: symbol-table-cursor? (* -> boolean))
    107106;
    108107(define (symbol-table-cursor? obj)
     
    135134;;
    136135
    137 (: cursor-next (symbol-table-cursor --> (or boolean symbol-table-cursor)))
     136(: cursor-next (symbol-table-cursor -> (or boolean symbol-table-cursor)))
    138137;
    139138(define (cursor-next cursor)
     
    142141    (let loop (
    143142      (bkt (bucket-link-ref (cursor-bucket cursor)))
    144       (idx (cursor-index cursor)))
     143      (idx (cursor-index cursor)) )
    145144      ;gotta bucket ?
    146145      (if (and bkt (not (bucket-last? bkt)))
     
    148147        (make-symbol-table-cursor idx bkt)
    149148        ;else try next hash-root slot
    150         (let ((idx (fx+ 1 idx)))
     149        (let ((idx (add1 idx)))
    151150          (and
    152151            ;more to go ?
    153             (fx< idx (root-symbol-table-size))
     152            (< idx (root-symbol-table-size))
    154153            ;this slot
    155154            (loop (root-symbol-table-element idx) idx) ) ) ) ) ) )
    156155
    157 (: cursor-first (--> (or boolean symbol-table-cursor)))
     156(: cursor-first (-> (or boolean symbol-table-cursor)))
    158157;
    159158(define (cursor-first)
    160159  (cursor-next (symbol-table-cursor)) )
    161160
    162 (: cursor-current (symbol-table-cursor --> (or boolean symbol)))
     161(: cursor-current (symbol-table-cursor -> (or boolean symbol)))
    163162;
    164163(define (cursor-current cursor)
  • release/5/apropos/trunk/tests/run.scm

    r37390 r38256  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import
    12   (only (chicken pathname) make-pathname)
    13   (only (chicken process) system)
    14   (only (chicken process-context) argv)
    15   (only (chicken format) format))
     11(import (only (chicken pathname) make-pathname))
     12(import (only (chicken process) system))
     13(import (only (chicken process-context) argv))
     14(import (only (chicken format) format))
    1615
    1716(define (test-filename test-name)
Note: See TracChangeset for help on using the changeset viewer.