Changeset 9512 in project


Ignore:
Timestamp:
03/12/08 16:14:23 (12 years ago)
Author:
Kon Lovett
Message:

Rmvd dep procs. Updated doc.

Location:
release/3/misc-extn
Files:
20 edited

Legend:

Unmodified
Added
Removed
  • release/3/misc-extn/tags/3.1/misc-extn-control-support.scm

    r8075 r9512  
    11;;;; misc-extn-control-support.scm
    22;;;; Kon Lovett, Jul '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1412      assure
    1513      identify-error
    16       errorf) ) )
     14      errorf ) ) )
     15
     16(use srfi-1)
    1717
    1818;;; Error Invocation
     
    3333        (let ([caller msg])
    3434          (set! msg
    35             (let ([msg (and (pair? args) (car args))])
    36               (when msg
    37                 (set! args (cdr args)))
    38               msg))
     35               (and-let* ([msg (and (pair? args) (car args))])
     36                 (set! args (cdr args))))
    3937          (display "(") (display caller) (display ") ")))
    4038      (when msg
  • release/3/misc-extn/tags/3.1/misc-extn-control.scm

    r6200 r9512  
    1010                (lambda (typ)
    1111                  `(,(string->symbol (string-append (symbol->string typ) "?")) ,?var))])
    12             (let loop ([forms ?forms] [lst '()])
     12            (let loop ([forms ?forms]
     13                       [lst '()])
    1314              (if (null? forms)
    1415                  (reverse lst)
     
    1617                    (if (pair? tcase)
    1718                        (let ([typ (car tcase)])
    18                           (loop
    19                             (cdr forms)
    20                             (cons
    21                               (cons
    22                                 (cond [(eq? 'else typ)
    23                                         'else]
    24                                       [(symbol? typ)
    25                                         (make-type-pred typ)]
    26                                       [(pair? typ)
    27                                         `(or ,@(map make-type-pred typ))]
    28                                       [else
    29                                         (syntax-error loc "invalid case" tcase)])
    30                                 (cdr tcase))
    31                               lst)))
     19                          (loop (cdr forms)
     20                                (cons (cons (cond [(eq? 'else typ)
     21                                                    'else]
     22                                                  [(symbol? typ)
     23                                                    (make-type-pred typ)]
     24                                                  [(pair? typ)
     25                                                    `(or ,@(map make-type-pred typ))]
     26                                                  [else
     27                                                    (syntax-error loc "invalid case" tcase)])
     28                                            (cdr tcase))
     29                                      lst)))
    3230                        (syntax-error loc "invalid case" tcase)))))))) )
    3331
  • release/3/misc-extn/tags/3.1/misc-extn-directory.scm

    r8121 r9512  
    11;;;; misc-extn-directory.scm
    22;;;; Kon Lovett, Sep '07
    3 
    4 (use srfi-1 srfi-13 utils posix)
    5 (use misc-extn-list stack miscmacros)
    63
    74(eval-when (compile)
     
    1916                create-pathname-directory
    2017                make-program-filename
     18                make-shell-filename
    2119                file-exists/directory?
    2220                find-file-pathnames
    2321                find-program-pathnames
     22                which-command-pathnames
    2423                which-command-pathname
    2524                remove-dotfiles
    2625          ; Deprecated
    27                 which-command-directory) ) )
     26                which-command-directory ) ) )
     27
     28(use srfi-1 srfi-13 utils posix)
     29(use misc-extn-list stack miscmacros)
     30
     31;;; Locals
     32
     33(cond-expand
     34  [windows  (define-constant PATH-DELIMITER ";")]
     35  [else     (define-constant PATH-DELIMITER ":")])
    2836
    2937;;; Directory Stuff
     
    8189      bn]) )
    8290
     91(define (make-shell-filename bn)
     92  (cond-expand
     93    [windows
     94      (if (pathname-extension bn)
     95          bn
     96          (make-pathname #f bn ".bat"))]
     97    [else
     98      (if (pathname-extension bn)
     99          bn
     100          (make-pathname #f bn ".sh"))]) )
     101
    83102;; Pathname if file exists in directory.
    84103
     
    91110
    92111(define (find-file-pathnames fil . dirs)
    93   (let loop ([dirs dirs] [paths '()])
     112  (let loop ([dirs dirs]
     113             [paths '()])
    94114    (if (null? dirs)
    95115        (not-null? paths)
    96116        (let ([dir (car dirs)])
    97117          (loop (cdr dirs)
    98             (append! paths
    99                      (filter-map (cut file-exists/directory? fil <>)
    100                                  (ensure-list dir)))))) ) )
     118                (append! paths
     119                         (filter-map (cut file-exists/directory? fil <>)
     120                                     (ensure-list dir)))))) ) )
     121
     122;; All found program pathname in directories.
    101123
    102124(define (find-program-pathnames cmd . dirs)
    103   (apply find-file-pathnames
    104          (make-program-filename cmd)
    105          dirs) )
     125   (cond-expand
     126    [windows
     127      (if (pathname-extension bn)
     128          (apply find-file-pathnames cmd dirs)
     129          (let ([pfs (apply find-file-pathnames (make-program-filename cmd) dirs)]
     130                [sfs (apply find-file-pathnames (make-shell-filename cmd) dirs)])
     131            (not-null? (append! (or pfs '()) (or sfs '()))) ) ) ]
     132    [else
     133      (apply find-file-pathnames (make-program-filename cmd) dirs) ] ) )
     134
     135;; All found program pathname in path.
     136
     137(define (which-command-pathnames cmd . rest)
     138  (and-let* ([env-path (getenv (optional rest "PATH"))])
     139    (find-program-pathnames cmd (string-split env-path PATH-DELIMITER)) ) )
    106140
    107141;; First found program pathname in path.
    108142
    109 (cond-expand
    110   [windows (define-constant PATH-DELIMITER ";")]
    111   [else (define-constant PATH-DELIMITER ":")])
    112 
    113 (define (which-command-pathname cmd #!optional (env-var "PATH"))
    114   (and-let* ([env-path (getenv env-var)]
    115              [paths
    116               (find-program-pathnames cmd
    117                                       (string-split env-path PATH-DELIMITER))])
    118     (first paths) ) )
     143(define (which-command-pathname cmd . rest)
     144  (and-let* ([ps (apply which-command-pathnames cmd rest)])
     145    (first ps) ) )
    119146
    120147;; Remove dot files from a directory list
    121148
    122149(define (remove-dotfiles files)
    123         (remove
    124                 (lambda (pn)
    125                         (string-prefix? "." (pathname-file pn)))
    126                 files) )
     150        (remove (lambda (pn) (string-prefix? "." (pathname-file pn))) files) )
    127151
    128152;; Deprecated
  • release/3/misc-extn/tags/3.1/misc-extn-dsssl-support.scm

    r6202 r9512  
    11;;;; misc-extn-dsssl-support.scm
    22;;;; Kon Lovett, Aug '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1311      fixup-extended-lambda-list-rest
    1412      fixup-extended-lambda-list-optional
    15       fixup-extended-lambda-list) ) )
     13      fixup-extended-lambda-list ) ) )
     14
     15(use srfi-1)
    1616
    1717;;; DSSSL Extended Lambda List
  • release/3/misc-extn/tags/3.1/misc-extn-eggdoc.scm

    r8075 r9512  
    235235
    236236        (procedure "(unzip-alist ALIST)"
    237           (p "Returns 2 values, a list of the keys & a list of the values from
    238           the " (tt "ALIST") ".") )
     237          (p "Returns 2 values, a list of the keys & a list of the values from "
     238          "the " (tt "ALIST") ".") )
    239239
    240240        (procedure "(zip-alist KEYS VALUES)"
     
    339339      (subsection "Directories"
    340340
     341        (usage "(require-extension misc-extn-directory)")
     342
    341343        (procedure "(push-directory DIRECTORY)"
    342344          (p "Push the current directory and change to the " (tt "DIRECTORY") ".") )
     
    351353          (p "Ensures the directory pathname " (tt "DIRECTORY") " exists.")
    352354
    353           (p "Like the UNIX `\"mkdir -p DIRECTORY\" command.") )
     355          (p "Like the *NIX `\"mkdir -p DIRECTORY\" command.") )
    354356
    355357        (procedure "(create-pathname-directory PATHNAME)"
    356358          (p "Ensures the directory component of " (tt "PATHNAME") " exist.")
    357359
    358           (p "Like the UNIX `\"mkdir -p `dirname PATHNAME`\" command.") )
     360          (p "Like the *NIX `\"mkdir -p `dirname PATHNAME`\" command.") )
    359361
    360362        (procedure "(make-program-filename COMMAND)"
     
    365367          "extension is already present. Does nothing on other platforms.") )
    366368
     369        (procedure "(make-shell-filename COMMAND)"
     370          (p "Returns the platform specific form of a shell command "
     371          "filename.")
     372
     373          (p "On Windows the " (code "bat") " extension is added unless an "
     374          "extension is already present. On *NIX platforms adds " (code ".sh") ".") )
     375
    367376        (procedure "(file-exists/directory? FILENAME [DIRECTORY | DIRECTORY-LIST])"
    368377          (p "Returns the pathname when " (tt "FILENAME") " exists in the "
     
    387396          (p "Uses " (code "make-program-filename") " to make a filename.")
    388397
     398          (p "On Windows also uses " (code "make-shell-filename") " to make a filename.")
     399
    389400          (p "Does not ensure that the file is executable!") )
    390401
    391         (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])"
    392           (p "Returns the first directory in the " (tt "ENVIRONMENT-VARIABLE") " "
    393           "where a file named " (tt "COMMAND-NAME") " exists, "
    394           "or " (code "#f") " when nothing found.")
    395 
    396           (p "Uses the platform specific PATH environment variable element "
    397           "separator - a semi-colon for Windows, & a colon otherwise.")
    398 
    399           (p "Like the UNIX \"which COMMAND-NAME\" command.") )
     402        (procedure "(which-command-pathnames COMMAND-NAME [ENVIRONMENT-VARIABLE])"
     403          (p "Returns the pathnames of " (tt "COMMAND-NAME") " in the " (tt
     404          "ENVIRONMENT-VARIABLE") " where the file exists, or " (code "#f") " "
     405          "when nothing found.")
     406
     407          (p "The default " (tt "ENVIRONMENT-VARIABLE") " is " (code "\"PATH\"") ".")
     408
     409          (p "Uses the platform specific \"PATH\" environment variable element "
     410          "separator - a ';' for Windows, & a ':' otherwise.") )
     411
     412        (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE])"
     413          (p "Same as " (code "which-command-pathnames") " but returns the "
     414          "first pathname only.")
     415
     416          (p "Like the *NIX \"which COMMAND-NAME\" command.") )
    400417
    401418        (procedure "(remove-dotfiles FILES)"
  • release/3/misc-extn/tags/3.1/misc-extn-list-support.scm

    r8075 r9512  
    11;;;; misc-extn-list-support.scm
    22;;;; Kon Lovett, Jul '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1210    (no-bound-checks)
    1311    (bound-to-procedure
    14       ##sys#check-pair)
     12      ##sys#check-pair )
    1513    (export
    1614      length=0?
     
    2725      unzip-alist
    2826      zip-alist
    29       filter-rest-argument!
    30       fixup-extended-lambda-list-rest
    31       fixup-extended-lambda-list-optional
    32       fixup-extended-lambda-list
    33       ;; Deprecated
    34       filter-rest-argument!
    35       alist-delete*
    3627      shift!
    37       unshift!) ) )
     28      unshift! ) ) )
     29
     30(use srfi-1)
    3831
    3932;;;
     
    7972(define (not-null? lst)
    8073  (and (not (null? lst))
    81        lst) )
    82 
    83 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    84 
    85 (define (filter-rest-argument! args #!optional testarg)
    86   (let* (
    87       [make-pred
    88         (lambda (itmtst)
    89           (let ([key? #f])
    90             (lambda (arg)
    91               (cond [key?
    92                       (set! key? #f)
    93                       #f]
    94                     [(keyword? arg)
    95                       (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    96                     [else
    97                       #t]))))]
    98       [pred
    99         (cond [(procedure? testarg)   testarg]
    100               [(list? testarg)        (make-pred memq)]
    101               [(not testarg)          (make-pred (lambda (arg lst) #t))]
    102               [else
    103                 (error 'filter-rest-argument!
    104                   "test argument not a procedure or list" testarg)])])
    105     (filter! pred args) ) )
    106 
    107 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    108 
    109 (define (fixup-extended-lambda-list-rest keys rest #!optional (skip? #f))
    110   (let loop ([rest rest] [skip? skip?] [lst '()])
    111     (if (null? rest)
    112         (reverse! lst)
    113         (let ([arg (car rest)]
    114               [nxt (cdr rest)])
    115           (cond [skip?            (loop nxt #f lst)]
    116                 [(memq arg keys)  (loop nxt #t lst)]
    117                 [else             (loop nxt #f (cons arg lst))]) ) ) ) )
    118 
    119 ;; Remove any keyword from #!optional argument.
    120 
    121 (define (fixup-extended-lambda-list-optional keys . opts)
    122   (let loop ([opts opts] [skip? #f] [lst '()])
    123     (if (null? opts)
    124         (values skip? (reverse! lst))
    125         (let ([opt (car opts)]
    126               [nxt (cdr opts)])
    127           (let ([val (car opt)]
    128                 [def (cadr opt)])
    129             (cond [skip?            (loop nxt #f (cons def lst))]
    130                   [(memq val keys)  (loop nxt #t (cons def lst))]
    131                   [else             (loop nxt #f (cons val lst))]) ) ) ) ) )
    132 
    133 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    134 
    135 (define (fixup-extended-lambda-list keys rest . opts)
    136   (let-values ([(skip? fixed-opts) (apply fixup-extended-lambda-list-optional keys opts)])
    137     (apply values (fixup-extended-lambda-list-rest keys rest skip?) fixed-opts) ) )
     74       lst ) )
    13875
    13976;; Search the alist from back to front.
     
    14178(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    14279  (let ([cell (rassoc val alist cmp)])
    143     (if cell (car cell) default) ) )
     80    (if cell
     81        (car cell)
     82        default ) ) )
    14483
    14584;; Remove 1st N matching elements from the alist [functional]
     
    165104          [else
    166105            (error 'alist-delete/count "invalid association list" al)]) ) )
    167 
    168 (define (alist-delete* key al #!optional (cnt 1073741823) (cmp equal?))
    169   (alist-delete/count key al cmp cnt) )
    170106
    171107;; Remove 1st N matching elements from the alist [destructive]
     
    208144  (let loop ([alist alist] [keys '()] [vals '()])
    209145    (if (null? alist)
    210       (values (reverse! keys) (reverse! vals))
    211       (let ([elm (car alist)])
    212         (if (pair? elm)
    213           (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
    214           (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
     146        (values (reverse! keys) (reverse! vals))
     147        (let ([elm (car alist)])
     148          (if (pair? elm)
     149              (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
     150              (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
    215151
    216152;;
     
    218154(define (zip-alist keys vals)
    219155  (map cons keys vals) )
    220 
    221 ;;; Deprecated
    222 
    223 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    224 
    225 (define (filter-rest-argument! args #!optional testarg)
    226   (let* (
    227       [make-pred
    228         (lambda (itmtst)
    229           (let ([key? #f])
    230             (lambda (arg)
    231               (cond [key?
    232                       (set! key? #f)
    233                       #f]
    234                     [(keyword? arg)
    235                       (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    236                     [else
    237                       #t]))))]
    238       [pred
    239         (cond [(procedure? testarg)   testarg]
    240               [(list? testarg)        (make-pred memq)]
    241               [(not testarg)          (make-pred (lambda (arg lst) #t))]
    242               [else
    243                 (error 'filter-rest-argument!
    244                   "test argument not a procedure or list" testarg)])])
    245     (filter! pred args) ) )
    246 
    247156
    248157;;; Handy little things:
     
    258167          (set-car! lst (car d))
    259168          (set-cdr! lst (cdr d))
    260           x) ) ) )
     169          x ) ) ) )
    261170
    262171(define (unshift! x lst)
  • release/3/misc-extn/tags/3.1/misc-extn-posix.scm

    r8075 r9512  
    33
    44;; Issues
     5;;
    56;; - The termios struct interface is conditioned on macos, where I know the i/ospeed
    67;; elements are defined.
     
    89;; This can be done better - actually check for the field's existence in the
    910;; .setup w/ a 'try-compile' & then pass info as a '-feature SYMBOL'.
    10 
    11 (use posix)
    12 (use misc-extn-directory) ; For Now
    1311
    1412(eval-when (compile)
     
    5856      open-pty
    5957      login-tty
    60       replace-fileno) ) )
     58      replace-fileno ) ) )
     59
     60(use posix)
    6161
    6262;;;
     
    7373;; process-spawn
    7474
    75 #+(not windows)
    76 (begin
    77   (define spawn/overlay   0)
    78   (define spawn/wait      1)
    79   (define spawn/nowait    2)
    80   (define spawn/nowaito   3)
    81   (define spawn/detach    4)
    82 
    83   (define (process-spawn mode command #!optional arguments environment exact?)
    84     )
     75(cond-expand
     76  [(not windows)
     77    (define spawn/overlay   0)
     78    (define spawn/wait      1)
     79    (define spawn/nowait    2)
     80    (define spawn/nowaito   3)
     81    (define spawn/detach    4)
     82
     83    (define (process-spawn mode command #!optional arguments environment exact?)
     84      ) ]
     85  [else] )
    8586|#
    8687
  • release/3/misc-extn/tags/3.1/misc-extn-record.scm

    r5437 r9512  
    1111    `(begin
    1212       (define ,conser
    13          (##sys#make-structure
    14            ',t
    15            ,@(map
    16                (lambda (sname)
    17                  (if (memq sname vars)
    18                    sname
    19                    '(##sys#void) ) )
    20                slotnames) ) )
     13         (##sys#make-structure ',t
     14                               ,@(map (lambda (sname)
     15                                        (if (memq sname vars)
     16                                            sname
     17                                            '(##sys#void) ) )
     18                                      slotnames) ) )
    2119       (define (,pred x) (##sys#structure? x ',t))
    2220       ,@(let loop ([slots slots] [i 1])
    2321           (if (null? slots)
    24              '()
    25              (let ([slot (car slots)])
    26                (let ([setters (memq #:record-setters ##sys#features)]
    27                      [setr? (pair? (cddr slot))]
    28                      [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
    29                  `(,@(if setr?
    30                        `((define (,(caddr slot) x y)
    31                            (##sys#block-set! x ,i y)) )
    32                        '() )
    33                    (define ,(cadr slot)
    34                      ,(if (and setr? setters)
    35                         `(getter-with-setter ,getr ,(caddr slot))
    36                          getr) )
    37                    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
     22               '()
     23               (let ([slot (car slots)])
     24                 (let ([setters (memq #:record-setters ##sys#features)]
     25                       [setr? (pair? (cddr slot))]
     26                       [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
     27                   `(,@(if setr?
     28                           `((define (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
     29                           '() )
     30                     (define ,(cadr slot)
     31                       ,(if (and setr? setters)
     32                            `(getter-with-setter ,getr ,(caddr slot))
     33                             getr) )
     34                     ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
    3835
    3936;; SRFI-9 workalike w/o record type checking and inline procedures.
     
    4441    `(begin
    4542       (define-inline ,conser
    46          (##sys#make-structure
    47            ',t
    48            ,@(map
    49                (lambda (sname)
    50                  (if (memq sname vars)
    51                    sname
    52                    '(##sys#void) ) )
    53                slotnames) ) )
     43         (##sys#make-structure ',t
     44                               ,@(map (lambda (sname)
     45                                        (if (memq sname vars)
     46                                            sname
     47                                            '(##sys#void) ) )
     48                                      slotnames) ) )
    5449       (define-inline (,pred x) (##sys#structure? x ',t))
    5550       ,@(let loop ([slots slots] [i 1])
    5651           (if (null? slots)
    57              '()
    58              (let ([slot (car slots)])
    59                `(,@(if (pair? (cddr slot))
    60                      `((define-inline (,(caddr slot) x y)
    61                        (##sys#block-set! x ,i y)) )
    62                       '() )
    63                  (define-inline (,(cadr slot) x)
    64                    (##sys#block-ref x ,i) )
    65                  ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
     52               '()
     53               (let ([slot (car slots)])
     54                 `(,@(if (pair? (cddr slot))
     55                         `((define-inline (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
     56                          '() )
     57                   (define-inline (,(cadr slot) x) (##sys#block-ref x ,i) )
     58                   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
  • release/3/misc-extn/tags/3.1/misc-extn-symbol-support.scm

    r5437 r9512  
    44(eval-when (compile)
    55  (declare
     6    (usual-integrations)
    67    (fixnum)
    78    (inline)
    89    (no-procedure-checks)
    910    (no-bound-checks)
    10     (import
    11       ##sys#interned-symbol?
    12       ##sys#make-symbol
    13       ##sys#symbol->qualified-string
    14       ##sys#qualified-symbol-prefix
    15       ##sys#intern-symbol)
    1611    (bound-to-procedure
    1712      ##sys#interned-symbol?
     
    1914      ##sys#symbol->qualified-string
    2015      ##sys#qualified-symbol-prefix
    21       ##sys#intern-symbol)
     16      ##sys#intern-symbol )
    2217    (export
    2318      interned-symbol?
     
    2520      make-qualified-uninterned-symbol
    2621      make-qualified-symbol
    27       qualified-symbol?) ) )
     22      qualified-symbol? ) ) )
    2823
    2924;;
     
    4540         [nsl (string-length ns)])
    4641    (if (<= 1 nsl NAMESPACE-MAX-ID-LEN)
    47       (conc (integer->char nsl) ns sym)
    48       (error loc "invalid namespace identifier length" ns) ) ) )
     42        (conc (integer->char nsl) ns sym)
     43        (error loc "invalid namespace identifier length" ns) ) ) )
    4944
    5045;; Chicken namespace qualified symbol.
     
    5853(define (qualified-symbol? sym)
    5954  (check-symbol sym 'qualified-symbol?)
    60   (not (not (##sys#qualified-symbol-prefix sym))) )
     55  (and (##sys#qualified-symbol-prefix sym)
     56       #t ) )
    6157
    6258(define (symbol->qualified-string sym)
  • release/3/misc-extn/tags/3.1/misc-extn.html

    r8077 r9512  
    265265<dt class="definition"><strong>procedure:</strong> (unzip-alist ALIST)</dt>
    266266<dd>
    267 <p>Returns 2 values, a list of the keys &amp; a list of the values from
    268           the <tt>ALIST</tt>.</p></dd>
     267<p>Returns 2 values, a list of the keys &amp; a list of the values from the <tt>ALIST</tt>.</p></dd>
    269268<dt class="definition"><strong>procedure:</strong> (zip-alist KEYS VALUES)</dt>
    270269<dd>
     
    347346<div class="subsection">
    348347<h4>Directories</h4>
     348<div class="section">
     349<h3>Usage</h3>(require-extension misc-extn-directory)</div>
    349350<dt class="definition"><strong>procedure:</strong> (push-directory DIRECTORY)</dt>
    350351<dd>
     
    359360<dd>
    360361<p>Ensures the directory pathname <tt>DIRECTORY</tt> exists.</p>
    361 <p>Like the UNIX `&quot;mkdir -p DIRECTORY&quot; command.</p></dd>
     362<p>Like the *NIX `&quot;mkdir -p DIRECTORY&quot; command.</p></dd>
    362363<dt class="definition"><strong>procedure:</strong> (create-pathname-directory PATHNAME)</dt>
    363364<dd>
    364365<p>Ensures the directory component of <tt>PATHNAME</tt> exist.</p>
    365 <p>Like the UNIX `&quot;mkdir -p `dirname PATHNAME`&quot; command.</p></dd>
     366<p>Like the *NIX `&quot;mkdir -p `dirname PATHNAME`&quot; command.</p></dd>
    366367<dt class="definition"><strong>procedure:</strong> (make-program-filename COMMAND)</dt>
    367368<dd>
    368369<p>Returns the platform specific form of an executable command filename.</p>
    369370<p>On Windows the <code>exe</code> extension is added unless an extension is already present. Does nothing on other platforms.</p></dd>
     371<dt class="definition"><strong>procedure:</strong> (make-shell-filename COMMAND)</dt>
     372<dd>
     373<p>Returns the platform specific form of a shell command filename.</p>
     374<p>On Windows the <code>bat</code> extension is added unless an extension is already present. On *NIX platforms adds <code>.sh</code>.</p></dd>
    370375<dt class="definition"><strong>procedure:</strong> (file-exists/directory? FILENAME [DIRECTORY | DIRECTORY-LIST])</dt>
    371376<dd>
     
    381386<p>Returns a list of all pathnames found for <tt>COMMAND-NAME</tt> in the supplied directory/directories, or <code>#f</code> when not found.</p>
    382387<p>Uses <code>make-program-filename</code> to make a filename.</p>
     388<p>On Windows also uses <code>make-shell-filename</code> to make a filename.</p>
    383389<p>Does not ensure that the file is executable!</p></dd>
    384 <dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])</dt>
    385 <dd>
    386 <p>Returns the first directory in the <tt>ENVIRONMENT-VARIABLE</tt> where a file named <tt>COMMAND-NAME</tt> exists, or <code>#f</code> when nothing found.</p>
    387 <p>Uses the platform specific PATH environment variable element separator - a semi-colon for Windows, &amp; a colon otherwise.</p>
    388 <p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></dd>
     390<dt class="definition"><strong>procedure:</strong> (which-command-pathnames COMMAND-NAME [ENVIRONMENT-VARIABLE])</dt>
     391<dd>
     392<p>Returns the pathnames of <tt>COMMAND-NAME</tt> in the <tt>ENVIRONMENT-VARIABLE</tt> where the file exists, or <code>#f</code> when nothing found.</p>
     393<p>The default <tt>ENVIRONMENT-VARIABLE</tt> is <code>&quot;PATH&quot;</code>.</p>
     394<p>Uses the platform specific &quot;PATH&quot; environment variable element separator - a ';' for Windows, &amp; a ':' otherwise.</p></dd>
     395<dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE])</dt>
     396<dd>
     397<p>Same as <code>which-command-pathnames</code> but returns the first pathname only.</p>
     398<p>Like the *NIX &quot;which COMMAND-NAME&quot; command.</p></dd>
    389399<dt class="definition"><strong>procedure:</strong> (remove-dotfiles FILES)</dt>
    390400<dd>
  • release/3/misc-extn/trunk/misc-extn-control-support.scm

    r8075 r9512  
    11;;;; misc-extn-control-support.scm
    22;;;; Kon Lovett, Jul '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1412      assure
    1513      identify-error
    16       errorf) ) )
     14      errorf ) ) )
     15
     16(use srfi-1)
    1717
    1818;;; Error Invocation
     
    3333        (let ([caller msg])
    3434          (set! msg
    35             (let ([msg (and (pair? args) (car args))])
    36               (when msg
    37                 (set! args (cdr args)))
    38               msg))
     35               (and-let* ([msg (and (pair? args) (car args))])
     36                 (set! args (cdr args))))
    3937          (display "(") (display caller) (display ") ")))
    4038      (when msg
  • release/3/misc-extn/trunk/misc-extn-control.scm

    r6200 r9512  
    1010                (lambda (typ)
    1111                  `(,(string->symbol (string-append (symbol->string typ) "?")) ,?var))])
    12             (let loop ([forms ?forms] [lst '()])
     12            (let loop ([forms ?forms]
     13                       [lst '()])
    1314              (if (null? forms)
    1415                  (reverse lst)
     
    1617                    (if (pair? tcase)
    1718                        (let ([typ (car tcase)])
    18                           (loop
    19                             (cdr forms)
    20                             (cons
    21                               (cons
    22                                 (cond [(eq? 'else typ)
    23                                         'else]
    24                                       [(symbol? typ)
    25                                         (make-type-pred typ)]
    26                                       [(pair? typ)
    27                                         `(or ,@(map make-type-pred typ))]
    28                                       [else
    29                                         (syntax-error loc "invalid case" tcase)])
    30                                 (cdr tcase))
    31                               lst)))
     19                          (loop (cdr forms)
     20                                (cons (cons (cond [(eq? 'else typ)
     21                                                    'else]
     22                                                  [(symbol? typ)
     23                                                    (make-type-pred typ)]
     24                                                  [(pair? typ)
     25                                                    `(or ,@(map make-type-pred typ))]
     26                                                  [else
     27                                                    (syntax-error loc "invalid case" tcase)])
     28                                            (cdr tcase))
     29                                      lst)))
    3230                        (syntax-error loc "invalid case" tcase)))))))) )
    3331
  • release/3/misc-extn/trunk/misc-extn-directory.scm

    r8121 r9512  
    11;;;; misc-extn-directory.scm
    22;;;; Kon Lovett, Sep '07
    3 
    4 (use srfi-1 srfi-13 utils posix)
    5 (use misc-extn-list stack miscmacros)
    63
    74(eval-when (compile)
     
    1916                create-pathname-directory
    2017                make-program-filename
     18                make-shell-filename
    2119                file-exists/directory?
    2220                find-file-pathnames
    2321                find-program-pathnames
     22                which-command-pathnames
    2423                which-command-pathname
    2524                remove-dotfiles
    2625          ; Deprecated
    27                 which-command-directory) ) )
     26                which-command-directory ) ) )
     27
     28(use srfi-1 srfi-13 utils posix)
     29(use misc-extn-list stack miscmacros)
     30
     31;;; Locals
     32
     33(cond-expand
     34  [windows  (define-constant PATH-DELIMITER ";")]
     35  [else     (define-constant PATH-DELIMITER ":")])
    2836
    2937;;; Directory Stuff
     
    8189      bn]) )
    8290
     91(define (make-shell-filename bn)
     92  (cond-expand
     93    [windows
     94      (if (pathname-extension bn)
     95          bn
     96          (make-pathname #f bn ".bat"))]
     97    [else
     98      (if (pathname-extension bn)
     99          bn
     100          (make-pathname #f bn ".sh"))]) )
     101
    83102;; Pathname if file exists in directory.
    84103
     
    91110
    92111(define (find-file-pathnames fil . dirs)
    93   (let loop ([dirs dirs] [paths '()])
     112  (let loop ([dirs dirs]
     113             [paths '()])
    94114    (if (null? dirs)
    95115        (not-null? paths)
    96116        (let ([dir (car dirs)])
    97117          (loop (cdr dirs)
    98             (append! paths
    99                      (filter-map (cut file-exists/directory? fil <>)
    100                                  (ensure-list dir)))))) ) )
     118                (append! paths
     119                         (filter-map (cut file-exists/directory? fil <>)
     120                                     (ensure-list dir)))))) ) )
     121
     122;; All found program pathname in directories.
    101123
    102124(define (find-program-pathnames cmd . dirs)
    103   (apply find-file-pathnames
    104          (make-program-filename cmd)
    105          dirs) )
     125   (cond-expand
     126    [windows
     127      (if (pathname-extension bn)
     128          (apply find-file-pathnames cmd dirs)
     129          (let ([pfs (apply find-file-pathnames (make-program-filename cmd) dirs)]
     130                [sfs (apply find-file-pathnames (make-shell-filename cmd) dirs)])
     131            (not-null? (append! (or pfs '()) (or sfs '()))) ) ) ]
     132    [else
     133      (apply find-file-pathnames (make-program-filename cmd) dirs) ] ) )
     134
     135;; All found program pathname in path.
     136
     137(define (which-command-pathnames cmd . rest)
     138  (and-let* ([env-path (getenv (optional rest "PATH"))])
     139    (find-program-pathnames cmd (string-split env-path PATH-DELIMITER)) ) )
    106140
    107141;; First found program pathname in path.
    108142
    109 (cond-expand
    110   [windows (define-constant PATH-DELIMITER ";")]
    111   [else (define-constant PATH-DELIMITER ":")])
    112 
    113 (define (which-command-pathname cmd #!optional (env-var "PATH"))
    114   (and-let* ([env-path (getenv env-var)]
    115              [paths
    116               (find-program-pathnames cmd
    117                                       (string-split env-path PATH-DELIMITER))])
    118     (first paths) ) )
     143(define (which-command-pathname cmd . rest)
     144  (and-let* ([ps (apply which-command-pathnames cmd rest)])
     145    (first ps) ) )
    119146
    120147;; Remove dot files from a directory list
    121148
    122149(define (remove-dotfiles files)
    123         (remove
    124                 (lambda (pn)
    125                         (string-prefix? "." (pathname-file pn)))
    126                 files) )
     150        (remove (lambda (pn) (string-prefix? "." (pathname-file pn))) files) )
    127151
    128152;; Deprecated
  • release/3/misc-extn/trunk/misc-extn-dsssl-support.scm

    r6202 r9512  
    11;;;; misc-extn-dsssl-support.scm
    22;;;; Kon Lovett, Aug '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1311      fixup-extended-lambda-list-rest
    1412      fixup-extended-lambda-list-optional
    15       fixup-extended-lambda-list) ) )
     13      fixup-extended-lambda-list ) ) )
     14
     15(use srfi-1)
    1616
    1717;;; DSSSL Extended Lambda List
  • release/3/misc-extn/trunk/misc-extn-eggdoc.scm

    r8075 r9512  
    235235
    236236        (procedure "(unzip-alist ALIST)"
    237           (p "Returns 2 values, a list of the keys & a list of the values from
    238           the " (tt "ALIST") ".") )
     237          (p "Returns 2 values, a list of the keys & a list of the values from "
     238          "the " (tt "ALIST") ".") )
    239239
    240240        (procedure "(zip-alist KEYS VALUES)"
     
    339339      (subsection "Directories"
    340340
     341        (usage "(require-extension misc-extn-directory)")
     342
    341343        (procedure "(push-directory DIRECTORY)"
    342344          (p "Push the current directory and change to the " (tt "DIRECTORY") ".") )
     
    351353          (p "Ensures the directory pathname " (tt "DIRECTORY") " exists.")
    352354
    353           (p "Like the UNIX `\"mkdir -p DIRECTORY\" command.") )
     355          (p "Like the *NIX `\"mkdir -p DIRECTORY\" command.") )
    354356
    355357        (procedure "(create-pathname-directory PATHNAME)"
    356358          (p "Ensures the directory component of " (tt "PATHNAME") " exist.")
    357359
    358           (p "Like the UNIX `\"mkdir -p `dirname PATHNAME`\" command.") )
     360          (p "Like the *NIX `\"mkdir -p `dirname PATHNAME`\" command.") )
    359361
    360362        (procedure "(make-program-filename COMMAND)"
     
    365367          "extension is already present. Does nothing on other platforms.") )
    366368
     369        (procedure "(make-shell-filename COMMAND)"
     370          (p "Returns the platform specific form of a shell command "
     371          "filename.")
     372
     373          (p "On Windows the " (code "bat") " extension is added unless an "
     374          "extension is already present. On *NIX platforms adds " (code ".sh") ".") )
     375
    367376        (procedure "(file-exists/directory? FILENAME [DIRECTORY | DIRECTORY-LIST])"
    368377          (p "Returns the pathname when " (tt "FILENAME") " exists in the "
     
    387396          (p "Uses " (code "make-program-filename") " to make a filename.")
    388397
     398          (p "On Windows also uses " (code "make-shell-filename") " to make a filename.")
     399
    389400          (p "Does not ensure that the file is executable!") )
    390401
    391         (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])"
    392           (p "Returns the first directory in the " (tt "ENVIRONMENT-VARIABLE") " "
    393           "where a file named " (tt "COMMAND-NAME") " exists, "
    394           "or " (code "#f") " when nothing found.")
    395 
    396           (p "Uses the platform specific PATH environment variable element "
    397           "separator - a semi-colon for Windows, & a colon otherwise.")
    398 
    399           (p "Like the UNIX \"which COMMAND-NAME\" command.") )
     402        (procedure "(which-command-pathnames COMMAND-NAME [ENVIRONMENT-VARIABLE])"
     403          (p "Returns the pathnames of " (tt "COMMAND-NAME") " in the " (tt
     404          "ENVIRONMENT-VARIABLE") " where the file exists, or " (code "#f") " "
     405          "when nothing found.")
     406
     407          (p "The default " (tt "ENVIRONMENT-VARIABLE") " is " (code "\"PATH\"") ".")
     408
     409          (p "Uses the platform specific \"PATH\" environment variable element "
     410          "separator - a ';' for Windows, & a ':' otherwise.") )
     411
     412        (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE])"
     413          (p "Same as " (code "which-command-pathnames") " but returns the "
     414          "first pathname only.")
     415
     416          (p "Like the *NIX \"which COMMAND-NAME\" command.") )
    400417
    401418        (procedure "(remove-dotfiles FILES)"
  • release/3/misc-extn/trunk/misc-extn-list-support.scm

    r8075 r9512  
    11;;;; misc-extn-list-support.scm
    22;;;; Kon Lovett, Jul '07
    3 
    4 (use srfi-1)
    53
    64(eval-when (compile)
     
    1210    (no-bound-checks)
    1311    (bound-to-procedure
    14       ##sys#check-pair)
     12      ##sys#check-pair )
    1513    (export
    1614      length=0?
     
    2725      unzip-alist
    2826      zip-alist
    29       filter-rest-argument!
    30       fixup-extended-lambda-list-rest
    31       fixup-extended-lambda-list-optional
    32       fixup-extended-lambda-list
    33       ;; Deprecated
    34       filter-rest-argument!
    35       alist-delete*
    3627      shift!
    37       unshift!) ) )
     28      unshift! ) ) )
     29
     30(use srfi-1)
    3831
    3932;;;
     
    7972(define (not-null? lst)
    8073  (and (not (null? lst))
    81        lst) )
    82 
    83 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    84 
    85 (define (filter-rest-argument! args #!optional testarg)
    86   (let* (
    87       [make-pred
    88         (lambda (itmtst)
    89           (let ([key? #f])
    90             (lambda (arg)
    91               (cond [key?
    92                       (set! key? #f)
    93                       #f]
    94                     [(keyword? arg)
    95                       (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    96                     [else
    97                       #t]))))]
    98       [pred
    99         (cond [(procedure? testarg)   testarg]
    100               [(list? testarg)        (make-pred memq)]
    101               [(not testarg)          (make-pred (lambda (arg lst) #t))]
    102               [else
    103                 (error 'filter-rest-argument!
    104                   "test argument not a procedure or list" testarg)])])
    105     (filter! pred args) ) )
    106 
    107 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    108 
    109 (define (fixup-extended-lambda-list-rest keys rest #!optional (skip? #f))
    110   (let loop ([rest rest] [skip? skip?] [lst '()])
    111     (if (null? rest)
    112         (reverse! lst)
    113         (let ([arg (car rest)]
    114               [nxt (cdr rest)])
    115           (cond [skip?            (loop nxt #f lst)]
    116                 [(memq arg keys)  (loop nxt #t lst)]
    117                 [else             (loop nxt #f (cons arg lst))]) ) ) ) )
    118 
    119 ;; Remove any keyword from #!optional argument.
    120 
    121 (define (fixup-extended-lambda-list-optional keys . opts)
    122   (let loop ([opts opts] [skip? #f] [lst '()])
    123     (if (null? opts)
    124         (values skip? (reverse! lst))
    125         (let ([opt (car opts)]
    126               [nxt (cdr opts)])
    127           (let ([val (car opt)]
    128                 [def (cadr opt)])
    129             (cond [skip?            (loop nxt #f (cons def lst))]
    130                   [(memq val keys)  (loop nxt #t (cons def lst))]
    131                   [else             (loop nxt #f (cons val lst))]) ) ) ) ) )
    132 
    133 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    134 
    135 (define (fixup-extended-lambda-list keys rest . opts)
    136   (let-values ([(skip? fixed-opts) (apply fixup-extended-lambda-list-optional keys opts)])
    137     (apply values (fixup-extended-lambda-list-rest keys rest skip?) fixed-opts) ) )
     74       lst ) )
    13875
    13976;; Search the alist from back to front.
     
    14178(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    14279  (let ([cell (rassoc val alist cmp)])
    143     (if cell (car cell) default) ) )
     80    (if cell
     81        (car cell)
     82        default ) ) )
    14483
    14584;; Remove 1st N matching elements from the alist [functional]
     
    165104          [else
    166105            (error 'alist-delete/count "invalid association list" al)]) ) )
    167 
    168 (define (alist-delete* key al #!optional (cnt 1073741823) (cmp equal?))
    169   (alist-delete/count key al cmp cnt) )
    170106
    171107;; Remove 1st N matching elements from the alist [destructive]
     
    208144  (let loop ([alist alist] [keys '()] [vals '()])
    209145    (if (null? alist)
    210       (values (reverse! keys) (reverse! vals))
    211       (let ([elm (car alist)])
    212         (if (pair? elm)
    213           (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
    214           (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
     146        (values (reverse! keys) (reverse! vals))
     147        (let ([elm (car alist)])
     148          (if (pair? elm)
     149              (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
     150              (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
    215151
    216152;;
     
    218154(define (zip-alist keys vals)
    219155  (map cons keys vals) )
    220 
    221 ;;; Deprecated
    222 
    223 ;; Remove any keywords & keyword-value pairs from a #!rest argument.
    224 
    225 (define (filter-rest-argument! args #!optional testarg)
    226   (let* (
    227       [make-pred
    228         (lambda (itmtst)
    229           (let ([key? #f])
    230             (lambda (arg)
    231               (cond [key?
    232                       (set! key? #f)
    233                       #f]
    234                     [(keyword? arg)
    235                       (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    236                     [else
    237                       #t]))))]
    238       [pred
    239         (cond [(procedure? testarg)   testarg]
    240               [(list? testarg)        (make-pred memq)]
    241               [(not testarg)          (make-pred (lambda (arg lst) #t))]
    242               [else
    243                 (error 'filter-rest-argument!
    244                   "test argument not a procedure or list" testarg)])])
    245     (filter! pred args) ) )
    246 
    247156
    248157;;; Handy little things:
     
    258167          (set-car! lst (car d))
    259168          (set-cdr! lst (cdr d))
    260           x) ) ) )
     169          x ) ) ) )
    261170
    262171(define (unshift! x lst)
  • release/3/misc-extn/trunk/misc-extn-posix.scm

    r8075 r9512  
    33
    44;; Issues
     5;;
    56;; - The termios struct interface is conditioned on macos, where I know the i/ospeed
    67;; elements are defined.
     
    89;; This can be done better - actually check for the field's existence in the
    910;; .setup w/ a 'try-compile' & then pass info as a '-feature SYMBOL'.
    10 
    11 (use posix)
    12 (use misc-extn-directory) ; For Now
    1311
    1412(eval-when (compile)
     
    5856      open-pty
    5957      login-tty
    60       replace-fileno) ) )
     58      replace-fileno ) ) )
     59
     60(use posix)
    6161
    6262;;;
     
    7373;; process-spawn
    7474
    75 #+(not windows)
    76 (begin
    77   (define spawn/overlay   0)
    78   (define spawn/wait      1)
    79   (define spawn/nowait    2)
    80   (define spawn/nowaito   3)
    81   (define spawn/detach    4)
    82 
    83   (define (process-spawn mode command #!optional arguments environment exact?)
    84     )
     75(cond-expand
     76  [(not windows)
     77    (define spawn/overlay   0)
     78    (define spawn/wait      1)
     79    (define spawn/nowait    2)
     80    (define spawn/nowaito   3)
     81    (define spawn/detach    4)
     82
     83    (define (process-spawn mode command #!optional arguments environment exact?)
     84      ) ]
     85  [else] )
    8586|#
    8687
  • release/3/misc-extn/trunk/misc-extn-record.scm

    r5437 r9512  
    1111    `(begin
    1212       (define ,conser
    13          (##sys#make-structure
    14            ',t
    15            ,@(map
    16                (lambda (sname)
    17                  (if (memq sname vars)
    18                    sname
    19                    '(##sys#void) ) )
    20                slotnames) ) )
     13         (##sys#make-structure ',t
     14                               ,@(map (lambda (sname)
     15                                        (if (memq sname vars)
     16                                            sname
     17                                            '(##sys#void) ) )
     18                                      slotnames) ) )
    2119       (define (,pred x) (##sys#structure? x ',t))
    2220       ,@(let loop ([slots slots] [i 1])
    2321           (if (null? slots)
    24              '()
    25              (let ([slot (car slots)])
    26                (let ([setters (memq #:record-setters ##sys#features)]
    27                      [setr? (pair? (cddr slot))]
    28                      [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
    29                  `(,@(if setr?
    30                        `((define (,(caddr slot) x y)
    31                            (##sys#block-set! x ,i y)) )
    32                        '() )
    33                    (define ,(cadr slot)
    34                      ,(if (and setr? setters)
    35                         `(getter-with-setter ,getr ,(caddr slot))
    36                          getr) )
    37                    ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
     22               '()
     23               (let ([slot (car slots)])
     24                 (let ([setters (memq #:record-setters ##sys#features)]
     25                       [setr? (pair? (cddr slot))]
     26                       [getr `(lambda (x) (##sys#block-ref x ,i) ) ] )
     27                   `(,@(if setr?
     28                           `((define (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
     29                           '() )
     30                     (define ,(cadr slot)
     31                       ,(if (and setr? setters)
     32                            `(getter-with-setter ,getr ,(caddr slot))
     33                             getr) )
     34                     ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) )
    3835
    3936;; SRFI-9 workalike w/o record type checking and inline procedures.
     
    4441    `(begin
    4542       (define-inline ,conser
    46          (##sys#make-structure
    47            ',t
    48            ,@(map
    49                (lambda (sname)
    50                  (if (memq sname vars)
    51                    sname
    52                    '(##sys#void) ) )
    53                slotnames) ) )
     43         (##sys#make-structure ',t
     44                               ,@(map (lambda (sname)
     45                                        (if (memq sname vars)
     46                                            sname
     47                                            '(##sys#void) ) )
     48                                      slotnames) ) )
    5449       (define-inline (,pred x) (##sys#structure? x ',t))
    5550       ,@(let loop ([slots slots] [i 1])
    5651           (if (null? slots)
    57              '()
    58              (let ([slot (car slots)])
    59                `(,@(if (pair? (cddr slot))
    60                      `((define-inline (,(caddr slot) x y)
    61                        (##sys#block-set! x ,i y)) )
    62                       '() )
    63                  (define-inline (,(cadr slot) x)
    64                    (##sys#block-ref x ,i) )
    65                  ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
     52               '()
     53               (let ([slot (car slots)])
     54                 `(,@(if (pair? (cddr slot))
     55                         `((define-inline (,(caddr slot) x y) (##sys#block-set! x ,i y)) )
     56                          '() )
     57                   (define-inline (,(cadr slot) x) (##sys#block-ref x ,i) )
     58                   ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) )
  • release/3/misc-extn/trunk/misc-extn-symbol-support.scm

    r5437 r9512  
    44(eval-when (compile)
    55  (declare
     6    (usual-integrations)
    67    (fixnum)
    78    (inline)
    89    (no-procedure-checks)
    910    (no-bound-checks)
    10     (import
    11       ##sys#interned-symbol?
    12       ##sys#make-symbol
    13       ##sys#symbol->qualified-string
    14       ##sys#qualified-symbol-prefix
    15       ##sys#intern-symbol)
    1611    (bound-to-procedure
    1712      ##sys#interned-symbol?
     
    1914      ##sys#symbol->qualified-string
    2015      ##sys#qualified-symbol-prefix
    21       ##sys#intern-symbol)
     16      ##sys#intern-symbol )
    2217    (export
    2318      interned-symbol?
     
    2520      make-qualified-uninterned-symbol
    2621      make-qualified-symbol
    27       qualified-symbol?) ) )
     22      qualified-symbol? ) ) )
    2823
    2924;;
     
    4540         [nsl (string-length ns)])
    4641    (if (<= 1 nsl NAMESPACE-MAX-ID-LEN)
    47       (conc (integer->char nsl) ns sym)
    48       (error loc "invalid namespace identifier length" ns) ) ) )
     42        (conc (integer->char nsl) ns sym)
     43        (error loc "invalid namespace identifier length" ns) ) ) )
    4944
    5045;; Chicken namespace qualified symbol.
     
    5853(define (qualified-symbol? sym)
    5954  (check-symbol sym 'qualified-symbol?)
    60   (not (not (##sys#qualified-symbol-prefix sym))) )
     55  (and (##sys#qualified-symbol-prefix sym)
     56       #t ) )
    6157
    6258(define (symbol->qualified-string sym)
  • release/3/misc-extn/trunk/misc-extn.html

    r8077 r9512  
    265265<dt class="definition"><strong>procedure:</strong> (unzip-alist ALIST)</dt>
    266266<dd>
    267 <p>Returns 2 values, a list of the keys &amp; a list of the values from
    268           the <tt>ALIST</tt>.</p></dd>
     267<p>Returns 2 values, a list of the keys &amp; a list of the values from the <tt>ALIST</tt>.</p></dd>
    269268<dt class="definition"><strong>procedure:</strong> (zip-alist KEYS VALUES)</dt>
    270269<dd>
     
    347346<div class="subsection">
    348347<h4>Directories</h4>
     348<div class="section">
     349<h3>Usage</h3>(require-extension misc-extn-directory)</div>
    349350<dt class="definition"><strong>procedure:</strong> (push-directory DIRECTORY)</dt>
    350351<dd>
     
    359360<dd>
    360361<p>Ensures the directory pathname <tt>DIRECTORY</tt> exists.</p>
    361 <p>Like the UNIX `&quot;mkdir -p DIRECTORY&quot; command.</p></dd>
     362<p>Like the *NIX `&quot;mkdir -p DIRECTORY&quot; command.</p></dd>
    362363<dt class="definition"><strong>procedure:</strong> (create-pathname-directory PATHNAME)</dt>
    363364<dd>
    364365<p>Ensures the directory component of <tt>PATHNAME</tt> exist.</p>
    365 <p>Like the UNIX `&quot;mkdir -p `dirname PATHNAME`&quot; command.</p></dd>
     366<p>Like the *NIX `&quot;mkdir -p `dirname PATHNAME`&quot; command.</p></dd>
    366367<dt class="definition"><strong>procedure:</strong> (make-program-filename COMMAND)</dt>
    367368<dd>
    368369<p>Returns the platform specific form of an executable command filename.</p>
    369370<p>On Windows the <code>exe</code> extension is added unless an extension is already present. Does nothing on other platforms.</p></dd>
     371<dt class="definition"><strong>procedure:</strong> (make-shell-filename COMMAND)</dt>
     372<dd>
     373<p>Returns the platform specific form of a shell command filename.</p>
     374<p>On Windows the <code>bat</code> extension is added unless an extension is already present. On *NIX platforms adds <code>.sh</code>.</p></dd>
    370375<dt class="definition"><strong>procedure:</strong> (file-exists/directory? FILENAME [DIRECTORY | DIRECTORY-LIST])</dt>
    371376<dd>
     
    381386<p>Returns a list of all pathnames found for <tt>COMMAND-NAME</tt> in the supplied directory/directories, or <code>#f</code> when not found.</p>
    382387<p>Uses <code>make-program-filename</code> to make a filename.</p>
     388<p>On Windows also uses <code>make-shell-filename</code> to make a filename.</p>
    383389<p>Does not ensure that the file is executable!</p></dd>
    384 <dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])</dt>
    385 <dd>
    386 <p>Returns the first directory in the <tt>ENVIRONMENT-VARIABLE</tt> where a file named <tt>COMMAND-NAME</tt> exists, or <code>#f</code> when nothing found.</p>
    387 <p>Uses the platform specific PATH environment variable element separator - a semi-colon for Windows, &amp; a colon otherwise.</p>
    388 <p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></dd>
     390<dt class="definition"><strong>procedure:</strong> (which-command-pathnames COMMAND-NAME [ENVIRONMENT-VARIABLE])</dt>
     391<dd>
     392<p>Returns the pathnames of <tt>COMMAND-NAME</tt> in the <tt>ENVIRONMENT-VARIABLE</tt> where the file exists, or <code>#f</code> when nothing found.</p>
     393<p>The default <tt>ENVIRONMENT-VARIABLE</tt> is <code>&quot;PATH&quot;</code>.</p>
     394<p>Uses the platform specific &quot;PATH&quot; environment variable element separator - a ';' for Windows, &amp; a ':' otherwise.</p></dd>
     395<dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE])</dt>
     396<dd>
     397<p>Same as <code>which-command-pathnames</code> but returns the first pathname only.</p>
     398<p>Like the *NIX &quot;which COMMAND-NAME&quot; command.</p></dd>
    389399<dt class="definition"><strong>procedure:</strong> (remove-dotfiles FILES)</dt>
    390400<dd>
Note: See TracChangeset for help on using the changeset viewer.