Changeset 38963 in project


Ignore:
Timestamp:
08/30/20 21:51:56 (4 weeks ago)
Author:
Kon Lovett
Message:

add -strict-types, remove redundant -local, update test runner, fix find-*-pathnames argument handling (match doc)

Location:
release/5/directory-utils/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/5/directory-utils/trunk/directory-utils.egg

    r38464 r38963  
    33
    44((synopsis "directory-utils")
    5  (version "2.2.1")
     5 (version "2.2.2")
    66 (category io)
    77 (author "[[kon lovett]]")
    88 (license "BSD")
    9  (dependencies
    10   (srfi-1 "0.1")
    11   (srfi-13 "0.1")
    12         (miscmacros "1.0")
    13         (moremacros "2.2.0")
    14         (list-utils "2.0.0")
    15         (stack "3.0.0")
    16         (check-errors "3.1.0"))
     9 (dependencies srfi-1 srfi-13 miscmacros moremacros list-utils stack check-errors)
    1710 (test-dependencies test)
    1811 (components
    1912  (extension directory-utils
    2013    (types-file)
    21     (csc-options "-O3" "-d1" "-local" "-no-procedure-checks-for-toplevel-bindings") ) ) )
     14    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings") ) ) )
  • release/5/directory-utils/trunk/directory-utils.scm

    r38262 r38963  
    4949(import (only (chicken file) file-exists? directory create-directory))
    5050(import (only (chicken file posix) directory?))
    51 (import (only (srfi 1) first fold append! filter-map remove any))
     51(import (only (srfi 1) concatenate fold append! filter-map remove any))
    5252(import (only (srfi 13) string-null? string-prefix?))
    5353(import (only miscmacros until))
     
    5858(import (only type-checks define-check+error-type check-procedure))
    5959
    60 ;;; Helpers
     60;; Helpers
    6161
    6262;;
     
    7171(define-type pathname string)
    7272
     73(: dot-filename-prefix? (filename -> boolean))
     74;NOTE do not type these as 'predicate', ex: (: filename? (* -> boolean : filename))
     75;since the compiler will treat a literal ".." as meeting the criteria at compile time!
     76(: pathname? (* --> boolean))
     77(: filename? (* --> boolean))
     78(: dot-filename? (* --> boolean))
     79(: dot-pathname? (* --> boolean))
     80(: remove-dotfiles ((list-of pathname) --> (list-of pathname)))
     81(: directory-fold (procedure * pathname #!rest -> *))
     82(: directory-utility-stack (#!optional stack -> stack))
     83(: ignored-directory? (pathname --> boolean))
     84(: push-directory ((or boolean pathname) #!optional stack -> void))
     85(: pop-directory (#!optional stack -> void))
     86(: pop-toplevel-directory (#!optional stack -> void))
     87(: create-pathname-directory (pathname -> boolean))
     88(: make-program-filename (basename --> filename))
     89(: make-shell-filename (basename -> filename))
     90(: file-exists-in-directory? (filename #!rest (list pathname) -> (or boolean pathname)))
     91(: find-file-pathnames-in-directory (filename pathname -> (list-of pathname)))
     92(: find-file-pathnames (filename #!rest -> (or boolean (list-of pathname))))
     93(: find-program-pathnames (filename #!rest (list-of pathname) -> optional-list))
     94(: which-command-pathnames (filename #!rest (list string) -> optional-list))
     95(: which-command-pathname (filename #!rest (list string) -> optional-list))
     96
     97(: *find-file-pathnames (filename (list-of pathname) -> (or boolean (list-of pathname))))
     98(: *find-program-pathnames (filename (list-of pathname) -> (or boolean (list-of pathname))))
     99
    73100;;
    74101
     
    85112
    86113;no . or .. since directoryname
    87 (: dot-filename-prefix? (filename -> boolean))
    88 ;
    89114(define (dot-filename-prefix? str)
    90115  (and
     
    93118    (not (or (string=? "." str) (string=? ".." str)))) )
    94119
    95 ;;;
     120;;
     121
     122(define (ensure-list-of args)
     123  ;ensure-list is a macro!
     124  (concatenate (map (lambda (x) (ensure-list x)) args)) )
    96125
    97126;;
     
    99128(define-check+error-type directory)
    100129
    101 ;NOTE do not type these as 'predicate', ex: (: filename? (* -> boolean : filename))
    102 ;since the compiler will treat a literal ".." as meeting the criteria at compile time!
    103 
    104130;; A null pathname or only extension is not a pathname, here at least
    105131
    106132; detecting only an extension is impossible with string pathnames
    107133
    108 (: pathname? (* --> boolean))
    109 ;
    110134(define (pathname? obj)
    111135  (and
     
    118142;; Just a filename, no directory
    119143
    120 (: filename? (* --> boolean))
    121 ;
    122144(define (filename? obj)
    123145  (and
     
    130152;;
    131153
    132 (: dot-filename? (* --> boolean))
    133 ;
    134154(define (dot-filename? obj)
    135155  (and
     
    139159;; Is any pathname component is a dot-filename?
    140160
    141 (: dot-pathname? (* --> boolean))
    142 ;
    143161(define (dot-pathname? obj)
    144162  (and
     
    156174;; Remove dot files from a directory list
    157175
    158 (: remove-dotfiles ((list-of pathname) --> (list-of pathname)))
    159 ;
    160176(define (remove-dotfiles files)
    161177        (remove (lambda (pn) (dot-filename? (pathname-file pn))) files) )
     
    163179;;
    164180
    165 (: directory-fold (procedure * pathname #!rest -> *))
    166 ;
    167181(define (directory-fold func ident dir . opts)
    168182  (let (
     
    175189;; Directory Stack
    176190
    177 (: directory-utility-stack (#!optional stack -> stack))
    178 ;
    179191(define-warning-parameter directory-utility-stack (make-stack) stack)
    180192
    181193;;
    182194
    183 (: ignored-directory? (pathname --> boolean))
    184 ;
    185195(define (ignored-directory? dir)
    186196  (or
     
    188198    (string=? +dot-directory+ (make-pathname dir #f))) )
    189199
    190 (: push-directory ((or boolean pathname) #!optional stack -> void))
    191 ;
    192200(define (push-directory dir #!optional (dirstack (directory-utility-stack)))
    193201  (stack-push! dirstack (current-directory))
     
    196204    (change-directory dir) ) )
    197205
    198 (: pop-directory (#!optional stack -> void))
    199 ;
    200206(define (pop-directory #!optional (dirstack (directory-utility-stack)))
    201207  (unless (stack-empty? dirstack)
    202208    (change-directory (stack-pop! dirstack)) ) )
    203209
    204 (: pop-toplevel-directory (#!optional stack -> void))
    205 ;
    206210(define (pop-toplevel-directory #!optional (dirstack (directory-utility-stack)))
    207211  (until (stack-empty? dirstack)
     
    210214;; Ensure the directory for the specified path exists.
    211215
    212 (: create-pathname-directory (pathname -> boolean))
    213 ;
    214216(define (create-pathname-directory pn)
    215217  (->boolean
     
    220222;; Platform specific program filename.
    221223
    222 (: make-program-filename (basename --> filename))
    223 ;
    224224(define (make-program-filename bn)
    225225  (cond-expand
     
    230230      bn ) ) )
    231231
    232 (: make-shell-filename (basename -> filename))
    233 ;
    234232(define (make-shell-filename bn)
    235233  (cond-expand
     
    243241;; Pathname if file exists in directory.
    244242
    245 (: file-exists-in-directory? (filename #!rest (list pathname) -> (or boolean pathname)))
    246 ;
    247243(define (file-exists-in-directory? fil . opts)
    248244  (let (
     
    254250;; List of all found pathnames.
    255251
    256 (: find-file-pathnames-in-directory (filename pathname -> (list-of pathname)))
    257 ;
    258252(define (find-file-pathnames-in-directory fil dir)
    259253  (filter-map
     
    261255    (ensure-list dir)) )
    262256
    263 (: *find-file-pathnames (filename (list-of pathname) -> (or boolean (list-of pathname))))
    264 ;
    265257(define (*find-file-pathnames fil dirs)
    266258  (let loop (
     
    274266          (find-file-pathnames-in-directory fil (car dirs))))) ) )
    275267
    276 (: find-file-pathnames (filename #!rest -> (or boolean (list-of pathname))))
    277 ;
    278268(define (find-file-pathnames fil . dirs)
    279   (*find-file-pathnames fil dirs) )
     269  (*find-file-pathnames fil (ensure-list-of dirs)) )
    280270
    281271;; All found program pathname in directories.
    282272
    283 (: find-program-pathnames (filename #!rest (list-of pathname) -> optional-list))
    284 ;
    285 (define (find-program-pathnames cmd . dirs)
     273(define (*find-program-pathnames cmd dirs)
    286274  (cond-expand
    287275    (windows
     
    296284      (*find-file-pathnames (make-program-filename cmd) dirs) ) ) )
    297285
     286(define (find-program-pathnames cmd . dirs)
     287  (*find-program-pathnames cmd (ensure-list-of dirs)) )
     288
    298289;; All found program pathname in path.
    299290
    300 (: which-command-pathnames (filename #!rest (list string) -> optional-list))
    301 ;
    302291(define (which-command-pathnames cmd . opts)
    303292  (let (
     
    305294    (and-let* (
    306295      (path (get-environment-variable varnam)) )
    307       (find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) ) )
     296      (*find-program-pathnames cmd (string-split path PATH-DELIMITER)) ) ) )
    308297
    309298;; First found program pathname in path.
    310299
    311 (: which-command-pathname (filename #!rest (list string) -> optional-list))
    312 ;
    313300(define (which-command-pathname cmd . opts)
    314301  (let (
     
    316303    (and-let* (
    317304      (ps (which-command-pathnames cmd varnam))
    318       ((not (zero? (length ps)))) )
    319       (first ps) ) ) )
     305      ((not (null? ps))) )
     306      (car ps) ) ) )
    320307
    321308) ;directory-utils
  • release/5/directory-utils/trunk/tests/directory-utils-test.scm

    r38464 r38963  
    3535(test '("abc/cbs.foo") (remove-dotfiles '(".hide" "abc/cbs.foo")))
    3636
    37 (test-assert (which-command-pathnames "mkdir"))
    38 (test-assert (not (which-command-pathnames "93274030#$%)#)$()")))
     37(test-assert (which-command-pathname "mkdir"))
     38(test-assert (not (which-command-pathname "93274030#$%)#)$()")))
    3939
    4040;run.scm test-gloss.incl.scm directory-utils-test.scm
  • release/5/directory-utils/trunk/tests/run.scm

    r38464 r38963  
    99;chicken-install invokes as "<csi> -s run.scm <eggnam> <eggdir>"
    1010
    11 (import (only (chicken pathname) make-pathname))
     11(import (only (chicken pathname)
     12  make-pathname pathname-file pathname-replace-directory pathname-strip-extension))
    1213(import (only (chicken process) system))
    1314(import (only (chicken process-context) argv))
    1415(import (only (chicken format) format))
     16(import (only (chicken file) file-exists? find-files))
     17(import (only (chicken irregex) irregex irregex-match?))
    1518
    1619(define *args* (argv))
    1720
    18 ;no -disable-interrupts
    19 (define *csc-options* "-inline-global \
     21(define (egg-name args #!optional (def EGG-NAME))
     22  (cond
     23    ((<= 4 (length *args*)) (cadddr *args*) )
     24    (def                    def )
     25    (else
     26      (error 'run "cannot determine egg-name") ) ) )
     27
     28(define *current-directory* (cond-expand (unix "./") (else #f)))
     29(define *egg* (egg-name *args*))
     30
     31;no -disable-interrupts or -no-lambda-info
     32(define *csc-options* "-inline-global -local -inline \
    2033  -specialize -optimize-leaf-routines -clustering -lfa2 \
    21   -local -inline \
    22   -no-trace -no-lambda-info \
    23   -unsafe")
     34  -no-trace -unsafe \
     35  -strict-types")
    2436
    25 (define (test-name #!optional (eggnam EGG-NAME))
    26   (string-append eggnam "-test") )
     37(define *test-files-rx* (irregex '(: (+ graph) #\- "test" #\. "scm")))
     38(define (test-filename name) (string-append name "-test"))
     39(define (test-files) (find-files "." #:test *test-files-rx* #:limit 1))
    2740
    28 (define (egg-name #!optional (def EGG-NAME))
    29   (cond
    30     ((<= 4 (length *args*))
    31       (cadddr *args*) )
    32     (def
    33       def )
    34     (else
    35       (error 'test "cannot determine egg-name") ) ) )
     41(define (ensure-test-source-name name)
     42  (if (irregex-match? *test-files-rx* name)
     43    name
     44    (make-pathname *current-directory* (test-filename name) "scm") ) )
     45
     46(define (run-test-evaluated source)
     47  (format #t "*** ~A - csi ***~%" (pathname-file source))
     48  (system (string-append "csi -s " source)) )
     49
     50(define (run-test-compiled source csc-options)
     51  (format #t "*** ~A - csc ~A ***~%" (pathname-file source) csc-options)
     52  ;csc output is in current directory
     53  (system (string-append "csc" " " csc-options " " source))
     54  (system (pathname-replace-directory (pathname-strip-extension source) *current-directory*)) )
    3655
    3756;;;
    3857
    39 (set! EGG-NAME (egg-name))
     58(define (run-test #!optional (name *egg*) (csc-options *csc-options*))
     59  (let (
     60    (source (ensure-test-source-name name)) )
     61    (unless (file-exists? source)
     62      (error 'run "no such file" source) )
     63    (run-test-evaluated source)
     64    (newline)
     65    (run-test-compiled source csc-options) ) )
    4066
    41 (define (run-test #!optional (eggnam EGG-NAME) (cscopts *csc-options*))
    42   (let ((tstnam (test-name eggnam)))
    43     (format #t "*** csi ***~%")
    44     (system (string-append "csi -s " (make-pathname #f tstnam "scm")))
    45     (newline)
    46     (format #t "*** csc ~s ***~%" cscopts)
    47     (system (string-append "csc" " " cscopts " " (make-pathname #f tstnam "scm")))
    48     (system (make-pathname (cond-expand (unix "./") (else #f)) tstnam)) ) )
     67(define (run-tests #!optional (tests (test-files)) (csc-options *csc-options*))
     68  (for-each (cut run-test <> csc-options) tests) )
    4969
    50 (define (run-tests eggnams #!optional (cscopts *csc-options*))
    51   (for-each (cut run-test <> cscopts) eggnams) )
     70;;; Do Test
    5271
    53 ;;;
    54 
    55 (run-test)
     72(run-tests)
Note: See TracChangeset for help on using the changeset viewer.