Changeset 8075 in project


Ignore:
Timestamp:
02/02/08 22:11:54 (12 years ago)
Author:
Kon Lovett
Message:

Rel 3.1, adds -directory stuff.

Location:
release/3/misc-extn
Files:
14 edited
1 copied

Legend:

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

    r5438 r8075  
    66(eval-when (compile)
    77  (declare
     8    (usual-integrations)
    89    (fixnum)
    910    (inline)
     
    1112    (no-bound-checks)
    1213    (export
    13       assure identify-error errorf) ) )
     14      assure
     15      identify-error
     16      errorf) ) )
    1417
    1518;;; Error Invocation
     
    1821
    1922(define (assure exp . err-args)
    20         (or exp (apply error err-args)))
     23        (or exp
     24            (apply error err-args)))
    2125
    2226;; Print error message but don't throw an exception
     
    4751      (set! loc format-string)
    4852      (if (null? rest)
    49         (set! format-string #f)
    50         (begin
    51           (set! format-string (car rest))
    52           (set! rest (cdr rest)) ) ) )
     53          (set! format-string #f)
     54          (begin
     55            (set! format-string (car rest))
     56            (set! rest (cdr rest)) ) ) )
    5357    (if format-string
    54       (error loc (apply format format-string rest))
    55       (error loc) ) ) )
     58        (error loc (apply format format-string rest))
     59        (error loc) ) ) )
  • release/3/misc-extn/tags/3.1/misc-extn-eggdoc.scm

    r6202 r8075  
    337337      )
    338338
    339       (subsection "Posix"
    340 
    341         (usage "(require-extension misc-extn-posix)")
    342 
    343         (procedure "(replace-fileno NEW-FILENO KNOWN-FILENO)"
    344           (p "Replaces the meaning of " (tt "KNOWN-FILENO") " with "
    345           (tt "NEW-FILENO") ". I/O Redirection.") )
     339      (subsection "Directories"
     340
     341        (procedure "(push-directory DIRECTORY)"
     342          (p "Push the current directory and change to the " (tt "DIRECTORY") ".") )
     343
     344        (procedure "(pop-directory)"
     345          (p "Pop the last directory and change to it.") )
     346
     347        (procedure "(pop-toplevel-directory)"
     348          (p "Pop the earliest directory and change to it.") )
    346349
    347350        (procedure "(create-directory/parents DIRECTORY)"
     
    386389          (p "Does not ensure that the file is executable!") )
    387390
    388         (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE "PATH"])"
     391        (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])"
    389392          (p "Returns the first directory in the " (tt "ENVIRONMENT-VARIABLE") " "
    390393          "where a file named " (tt "COMMAND-NAME") " exists, "
     
    398401        (procedure "(remove-dotfiles FILES)"
    399402          (p "Remove dot files from a directory list. Useful with " (code "glob") "."))
     403      )
     404
     405      (subsection "Posix"
     406
     407        (usage "(require-extension misc-extn-posix)")
     408
     409                                (subsubsection "File Descriptors"
     410
     411          (procedure "(replace-fileno NEW-FILENO KNOWN-FILENO)"
     412            (p "Replaces the meaning of " (tt "KNOWN-FILENO") " with "
     413            (tt "NEW-FILENO") ". I/O Redirection.") )
     414        )
    400415
    401416                                (subsubsection "Scheduling Priority"
     
    691706
    692707    (history
     708      (version "3.1" "Added misc-extn-directory; moved file-exists/directory, find-file-pathnames, find-program-pathnames, whch-command-pathname, remove-dotfiles from misc-extn-posix.")
    693709      (version "3.003" "Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.")
    694710      (version "3.002" "Reverted to 3.0 behavior for unbound Wasn't a bug.")
  • release/3/misc-extn/tags/3.1/misc-extn-list-support.scm

    r6207 r8075  
    66(eval-when (compile)
    77  (declare
     8    (usual-integrations)
    89    (fixnum)
    910    (inline)
    1011    (no-procedure-checks)
    1112    (no-bound-checks)
     13    (bound-to-procedure
     14      ##sys#check-pair)
    1215    (export
    13       ;; Deprecated
    14       filter-rest-argument!
    15       ;;
    16       length=0? length=1? length=2? length>1?
     16      length=0?
     17      length=1?
     18      length=2?
     19      length>1?
    1720      ensure-list
    1821      not-null?
    1922      alist-inverse-ref
    20       alist-delete/count alist-delete!/count
    21       alist-delete-first alist-delete-first!
    22       unzip-alist zip-alist
     23      alist-delete/count
     24      alist-delete!/count
     25      alist-delete-first
     26      alist-delete-first!
     27      unzip-alist
     28      zip-alist
    2329      filter-rest-argument!
    2430      fixup-extended-lambda-list-rest
    2531      fixup-extended-lambda-list-optional
    2632      fixup-extended-lambda-list
    27       ; Deprecated
    28       alist-delete*) ) )
     33      ;; Deprecated
     34      filter-rest-argument!
     35      alist-delete*
     36      shift!
     37      unshift!) ) )
    2938
    3039;;;
     
    235244                  "test argument not a procedure or list" testarg)])])
    236245    (filter! pred args) ) )
     246
     247
     248;;; Handy little things:
     249
     250(define (shift! lst #!optional default)
     251  (if (null? lst)
     252      default
     253      (begin
     254        (##sys#check-pair lst 'shift!)
     255        (let ([x (car lst)]
     256              [d (cdr lst)] )
     257          (##sys#check-pair d 'shift!)
     258          (set-car! lst (car d))
     259          (set-cdr! lst (cdr d))
     260          x) ) ) )
     261
     262(define (unshift! x lst)
     263  (##sys#check-pair lst 'unshift!)
     264  (set-car! lst x)
     265  (set-cdr! lst (cons (car lst) (cdr lst)))
     266  lst )
  • release/3/misc-extn/tags/3.1/misc-extn-posix.scm

    r5437 r8075  
    99;; .setup w/ a 'try-compile' & then pass info as a '-feature SYMBOL'.
    1010
    11 (use srfi-1 srfi-13 utils posix)
    12 (use misc-extn-list)
     11(use posix)
     12(use misc-extn-directory) ; For Now
    1313
    1414(eval-when (compile)
    1515  (declare
     16    (usual-integrations)
    1617        (inline)
    1718        (fixnum)
    1819                (no-procedure-checks)
    1920                (no-bound-checks)
    20     (import
    21       ##core#immutable
    22       ##sys#update-errno
    23       ##sys#error
    24       ##sys#posix-error)
    2521    (bound-to-procedure
    2622      ##core#immutable
    2723      ##sys#update-errno
    2824      ##sys#error
    29       ##sys#posix-error)
     25      #;##sys#posix-error)
    3026        (export
    31           ; deprecated
    32                 which-command-directory
    33                 ;
    3427      priority/process
    3528      priority/process-group
     
    6558      open-pty
    6659      login-tty
    67       replace-fileno
    68       create-directory/parents
    69                 create-pathname-directory
    70                 make-program-filename
    71                 file-exists/directory?
    72                 find-file-pathnames
    73                 find-program-pathnames
    74                 which-command-pathname
    75                 remove-dotfiles) ) )
     60      replace-fileno) ) )
    7661
    7762;;;
     
    8368       (##core#immutable '"this function is not available on this platform")) ) )
    8469
    85 ;;;
     70;;; Spawn Stuff
    8671
    8772#|
     
    11398posix_spawn_file_actions_addopen(posix_spawn_file_actions_t *restrict, int, const char *restrict, int, mode_t);
    11499
    115 ; FILE-ACTIONS init     
     100; FILE-ACTIONS init
    116101; FILE-ACTIONS destroy   FILE-ACTIONS
    117102; FILE-ACTIONS add       open FILE-ACTIONS FILENO PATH OPEN-FLAG MODE
     
    194179(cond-expand
    195180  [unix
     181
    196182    #>
    197183    #include <errno.h>
    198184    <#
    199185
    200     (define-foreign-variable _errno int "errno")
    201   ] [else
    202   ] )
     186    (define-foreign-variable _errno int "errno") ]
     187
     188  [else] )
    203189
    204190;; Process Priority
     
    206192(cond-expand
    207193  [unix
     194
    208195    #>
    209196    #include <sys/time.h>
     
    222209            (when (and (negative? res) (not (zero? _errno)))
    223210              (##sys#update-errno)
    224               (##sys#error 'scheduling-priority
    225                 "get priority failed" which who))
     211              (##sys#error 'scheduling-priority "get priority failed" which who))
    226212            res) ) ) )
    227213
     
    232218            (when (fx< res 0)
    233219              (##sys#update-errno)
    234               (##sys#error 'set-scheduling-priority!
    235                 "set priority failed" which who prio)) ) ) ) )
    236   ] [else
     220              (##sys#error 'set-scheduling-priority! "set priority failed" which who prio)) ) ) ) ) ]
     221
     222  [else
     223
    237224    (define priority/process (void))
    238225    (define priority/process-group (void))
    239226    (define priority/user (void))
    240227    (define-unimplemented scheduling-priority)
    241     (define-unimplemented set-scheduling-priority!)
    242   ] )
     228    (define-unimplemented set-scheduling-priority!) ] )
    243229
    244230;; Termios & Winsize Records
     
    246232(cond-expand
    247233  [unix
     234
    248235    #>
    249236    #include <termios.h>
     
    251238    <#
    252239
     240    ; ws_row        rows, in characters
     241    ; ws_col        columns, in characters
     242    ; ws_xpixel     horizontal size, in pixels
     243    ; ws_ypixel     vertical size, in pixels
     244
    253245    (define-foreign-record (winsize "struct winsize")
    254246      (rename: (cut string-translate* <> '(("ws_" . ""))))
    255247      (constructor: alloc-winsize)
    256248      (destructor: free-winsize)
    257       (unsigned-short  ws_row)        ; rows, in characters
    258       (unsigned-short  ws_col)        ; columns, in characters
    259       (unsigned-short  ws_xpixel)     ; horizontal size, pixels
    260       (unsigned-short  ws_ypixel) )   ; vertical size, pixels
     249      (unsigned-short  ws_row)
     250      (unsigned-short  ws_col)
     251      (unsigned-short  ws_xpixel)
     252      (unsigned-short  ws_ypixel) )
    261253
    262254    (define-foreign-type tcflag_t unsigned-long)
     
    267259    (cond-expand
    268260      [macosx
     261
     262        ; c_iflag                 input flags
     263        ; c_oflag                 output flags
     264        ; c_cflag                 control flags
     265        ; c_lflag                 local flags
     266        ; c_cc            control chars
     267        ; c_ispeed    input speed
     268        ; c_ospeed    output speed
     269
    269270        (define-foreign-record (termios "struct termios")
    270271          (rename: (cut string-translate* <> '(("c_" . ""))))
    271272          (constructor: alloc-termios)
    272273          (destructor: free-termios)
    273           (tcflag_t c_iflag)              ; input flags
    274           (tcflag_t c_oflag)              ; output flags
    275           (tcflag_t c_cflag)              ; control flags
    276           (tcflag_t c_lflag)              ; local flags
    277           (cc_t c_cc NCCS)                  ; control chars
    278           (speed_t c_ispeed)              ; input speed
    279           (speed_t c_ospeed) )    ; output speed
    280       ] [else
     274          (tcflag_t c_iflag)
     275          (tcflag_t c_oflag)
     276          (tcflag_t c_cflag)
     277          (tcflag_t c_lflag)
     278          (cc_t c_cc NCCS)
     279          (speed_t c_ispeed)
     280          (speed_t c_ospeed) ) ]
     281
     282      [else
     283
     284        ; c_iflag                 input flags
     285        ; c_oflag                 output flags
     286        ; c_cflag                 control flags
     287        ; c_lflag                 local flags
     288        ; c_cc            control chars
     289
    281290        (define-foreign-record (termios "struct termios")
    282291          (rename: (cut string-translate* <> '(("c_" . ""))))
    283292          (constructor: alloc-termios)
    284293          (destructor: free-termios)
    285           (tcflag_t c_iflag)              ; input flags
    286           (tcflag_t c_oflag)              ; output flags
    287           (tcflag_t c_cflag)              ; control flags
    288           (tcflag_t c_lflag)              ; local flags
    289           (cc_t c_cc NCCS) )              ; control chars
     294          (tcflag_t c_iflag)
     295          (tcflag_t c_oflag)
     296          (tcflag_t c_cflag)
     297          (tcflag_t c_lflag)
     298          (cc_t c_cc NCCS) )
     299
    290300        (define-unimplemented termios-ispeed)
    291301        (define-unimplemented termios-ispeed-set!)
    292302        (define-unimplemented termios-ospeed)
    293         (define-unimplemented termios-ospeed-set!)
    294     ])
    295   ] [else
     303        (define-unimplemented termios-ospeed-set!) ] ) ]
     304
     305  [else
     306
    296307    (define-unimplemented alloc-winsize)
    297308    (define-unimplemented free-winsize)
     
    319330    (define-unimplemented termios-cflag-set!)
    320331    (define-unimplemented termios-oflag-set!)
    321     (define-unimplemented termios-iflag-set!)
    322   ] )
     332    (define-unimplemented termios-iflag-set!) ] )
    323333
    324334;; Pseudo-tty
    325335
    326336#| Solaris open pty per pts(7D) manpage
     337
    327338    int    fdm fds;
    328339    char   *slavename;
     
    340351(cond-expand
    341352  [solaris
     353
    342354    (define-unimplemented open-pty)
    343     (define-unimplemented login-tty)
    344   ] [unix
     355    (define-unimplemented login-tty) ]
     356
     357  [unix
     358
    345359    #>
    346360    #if defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__)
     
    354368
    355369    (define open-pty
    356       (foreign-lambda int "openpty" (nonnull-pointer int) (nonnull-pointer int)
    357                                     c-string pointer pointer))
     370      (foreign-lambda int "openpty" (nonnull-c-pointer int) (nonnull-c-pointer int)
     371                                    c-string c-pointer c-pointer))
    358372
    359373    (define login-tty
    360       (foreign-lambda int "login_tty" int))
    361   ] [else
     374      (foreign-lambda int "login_tty" int)) ]
     375
     376  [else
     377
    362378    (define-unimplemented open-pty)
    363     (define-unimplemented login-tty)
    364   ] )
     379    (define-unimplemented login-tty) ] )
    365380
    366381;;
     
    370385    (duplicate-fileno fd sfd)
    371386    (file-close fd) ) )
    372 
    373 ;;; Directory Stuff
    374 
    375 ;; Ensure the directory exists.
    376 
    377 (define (create-directory/parents dir)
    378   (let loop ([dir dir])
    379     (when (and dir (not (directory? dir)))
    380       (loop (pathname-directory dir))
    381       (create-directory dir) ) ) )
    382 
    383 ;; Ensure the directory for the specified path exists.
    384 
    385 (define (create-pathname-directory pathname)
    386   (create-directory/parents (pathname-directory pathname)) )
    387 
    388 ;; Platform specific program filename.
    389 
    390 (define (make-program-filename bn)
    391   (cond-expand
    392     [windows
    393       (if (pathname-extension bn)
    394         bn
    395         (make-pathname #f bn ".exe"))]
    396     [else
    397       bn]) )
    398 
    399 ;; Pathname if file exists in directory.
    400 
    401 (define (file-exists/directory? fil #!optional dir)
    402   (let ([path (make-pathname dir fil)])
    403     (and (file-exists? path)
    404          path) ) )
    405 
    406 ;; List of all found pathnames.
    407 
    408 (define (find-file-pathnames fil . dirs)
    409   (let loop ([dirs dirs] [paths '()])
    410     (if (null? dirs)
    411       (not-null? paths)
    412       (let ([dir (car dirs)])
    413         (loop (cdr dirs)
    414           (append! paths
    415             (filter-map
    416               (cut file-exists/directory? fil <>)
    417               (ensure-list dir)))))) ) )
    418 
    419 (define (find-program-pathnames cmd . dirs)
    420   (apply find-file-pathnames
    421     (make-program-filename cmd)
    422     dirs) )
    423 
    424 ;; First found program pathname in path.
    425 
    426 (cond-expand
    427   [windows (define-constant PATH-DELIMITER ";")]
    428   [else (define-constant PATH-DELIMITER ":")])
    429 
    430 (define (which-command-pathname cmd #!optional (env-var "PATH"))
    431   (and-let* ([env-path (getenv env-var)]
    432              [paths
    433               (find-program-pathnames
    434                 cmd
    435                 (string-split env-path PATH-DELIMITER))])
    436     (first paths) ) )
    437 
    438 ;; Remove dot files from a directory list
    439 
    440 (define (remove-dotfiles files)
    441         (remove
    442                 (lambda (pn)
    443                         (string-prefix? "." (pathname-file pn)))
    444                 files) )
    445 
    446 ;; Deprecated
    447 
    448 (define which-command-directory which-command-pathname)
  • release/3/misc-extn/tags/3.1/misc-extn.html

    r6202 r8075  
    346346<p>Mutable flonum decrement.</p></dd></div>
    347347<div class="subsection">
    348 <h4>Posix</h4>
    349 <div class="section">
    350 <h3>Usage</h3>(require-extension misc-extn-posix)</div>
    351 <dt class="definition"><strong>procedure:</strong> (replace-fileno NEW-FILENO KNOWN-FILENO)</dt>
    352 <dd>
    353 <p>Replaces the meaning of <tt>KNOWN-FILENO</tt> with <tt>NEW-FILENO</tt>. I/O Redirection.</p></dd>
     348<h4>Directories</h4>
     349<dt class="definition"><strong>procedure:</strong> (push-directory DIRECTORY)</dt>
     350<dd>
     351<p>Push the current directory and change to the <tt>DIRECTORY</tt>.</p></dd>
     352<dt class="definition"><strong>procedure:</strong> (pop-directory)</dt>
     353<dd>
     354<p>Pop the last directory and change to it.</p></dd>
     355<dt class="definition"><strong>procedure:</strong> (pop-toplevel-directory)</dt>
     356<dd>
     357<p>Pop the earliest directory and change to it.</p></dd>
    354358<dt class="definition"><strong>procedure:</strong> (create-directory/parents DIRECTORY)</dt>
    355359<dd>
     
    378382<p>Uses <code>make-program-filename</code> to make a filename.</p>
    379383<p>Does not ensure that the file is executable!</p></dd>
    380 <dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE </dt>
    381 <dd>
    382 <PATH>])
     384<dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])</dt>
     385<dd>
    383386<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>
    384387<p>Uses the platform specific PATH environment variable element separator - a semi-colon for Windows, &amp; a colon otherwise.</p>
    385 <p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></PATH></dd>
     388<p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></dd>
    386389<dt class="definition"><strong>procedure:</strong> (remove-dotfiles FILES)</dt>
    387390<dd>
    388 <p>Remove dot files from a directory list. Useful with <code>glob</code>.</p></dd>
     391<p>Remove dot files from a directory list. Useful with <code>glob</code>.</p></dd></div>
     392<div class="subsection">
     393<h4>Posix</h4>
     394<div class="section">
     395<h3>Usage</h3>(require-extension misc-extn-posix)</div>
     396<div class="subsubsection">
     397<h5>File Descriptors</h5>
     398<dt class="definition"><strong>procedure:</strong> (replace-fileno NEW-FILENO KNOWN-FILENO)</dt>
     399<dd>
     400<p>Replaces the meaning of <tt>KNOWN-FILENO</tt> with <tt>NEW-FILENO</tt>. I/O Redirection.</p></dd></div>
    389401<div class="subsubsection">
    390402<h5>Scheduling Priority</h5>
     
    663675<h3>Version</h3>
    664676<ul>
     677<li>3.004 Added misc-extn-directory; moved file-exists/directory, find-file-pathnames, find-program-pathnames, whch-command-pathname, remove-dotfiles from misc-extn-posix.</li>
    665678<li>3.003 Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.</li>
    666679<li>3.002 Reverted to 3.0 behavior for unbound Wasn't a bug.</li>
  • release/3/misc-extn/tags/3.1/misc-extn.meta

    r6205 r8075  
    1212        "misc-extn-record.scm"
    1313        "misc-extn-io.scm"
     14        "misc-extn-directory.scm"
    1415        "misc-extn-posix.scm"
    1516        "misc-extn-list.scm" "misc-extn-list-support.scm"
  • release/3/misc-extn/tags/3.1/misc-extn.setup

    r6200 r8075  
    1616
    1717(install-dynld misc-extn-io *version* (documentation "misc-extn.html"))
     18(install-dynld misc-extn-directory *version* (documentation "misc-extn.html"))
    1819(install-dynld misc-extn-posix *version* (documentation "misc-extn.html"))
    1920
  • release/3/misc-extn/trunk/misc-extn-control-support.scm

    r5438 r8075  
    66(eval-when (compile)
    77  (declare
     8    (usual-integrations)
    89    (fixnum)
    910    (inline)
     
    1112    (no-bound-checks)
    1213    (export
    13       assure identify-error errorf) ) )
     14      assure
     15      identify-error
     16      errorf) ) )
    1417
    1518;;; Error Invocation
     
    1821
    1922(define (assure exp . err-args)
    20         (or exp (apply error err-args)))
     23        (or exp
     24            (apply error err-args)))
    2125
    2226;; Print error message but don't throw an exception
     
    4751      (set! loc format-string)
    4852      (if (null? rest)
    49         (set! format-string #f)
    50         (begin
    51           (set! format-string (car rest))
    52           (set! rest (cdr rest)) ) ) )
     53          (set! format-string #f)
     54          (begin
     55            (set! format-string (car rest))
     56            (set! rest (cdr rest)) ) ) )
    5357    (if format-string
    54       (error loc (apply format format-string rest))
    55       (error loc) ) ) )
     58        (error loc (apply format format-string rest))
     59        (error loc) ) ) )
  • release/3/misc-extn/trunk/misc-extn-eggdoc.scm

    r6202 r8075  
    337337      )
    338338
    339       (subsection "Posix"
    340 
    341         (usage "(require-extension misc-extn-posix)")
    342 
    343         (procedure "(replace-fileno NEW-FILENO KNOWN-FILENO)"
    344           (p "Replaces the meaning of " (tt "KNOWN-FILENO") " with "
    345           (tt "NEW-FILENO") ". I/O Redirection.") )
     339      (subsection "Directories"
     340
     341        (procedure "(push-directory DIRECTORY)"
     342          (p "Push the current directory and change to the " (tt "DIRECTORY") ".") )
     343
     344        (procedure "(pop-directory)"
     345          (p "Pop the last directory and change to it.") )
     346
     347        (procedure "(pop-toplevel-directory)"
     348          (p "Pop the earliest directory and change to it.") )
    346349
    347350        (procedure "(create-directory/parents DIRECTORY)"
     
    386389          (p "Does not ensure that the file is executable!") )
    387390
    388         (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE "PATH"])"
     391        (procedure "(which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])"
    389392          (p "Returns the first directory in the " (tt "ENVIRONMENT-VARIABLE") " "
    390393          "where a file named " (tt "COMMAND-NAME") " exists, "
     
    398401        (procedure "(remove-dotfiles FILES)"
    399402          (p "Remove dot files from a directory list. Useful with " (code "glob") "."))
     403      )
     404
     405      (subsection "Posix"
     406
     407        (usage "(require-extension misc-extn-posix)")
     408
     409                                (subsubsection "File Descriptors"
     410
     411          (procedure "(replace-fileno NEW-FILENO KNOWN-FILENO)"
     412            (p "Replaces the meaning of " (tt "KNOWN-FILENO") " with "
     413            (tt "NEW-FILENO") ". I/O Redirection.") )
     414        )
    400415
    401416                                (subsubsection "Scheduling Priority"
     
    691706
    692707    (history
     708      (version "3.1" "Added misc-extn-directory; moved file-exists/directory, find-file-pathnames, find-program-pathnames, whch-command-pathname, remove-dotfiles from misc-extn-posix.")
    693709      (version "3.003" "Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.")
    694710      (version "3.002" "Reverted to 3.0 behavior for unbound Wasn't a bug.")
  • release/3/misc-extn/trunk/misc-extn-list-support.scm

    r6207 r8075  
    66(eval-when (compile)
    77  (declare
     8    (usual-integrations)
    89    (fixnum)
    910    (inline)
    1011    (no-procedure-checks)
    1112    (no-bound-checks)
     13    (bound-to-procedure
     14      ##sys#check-pair)
    1215    (export
    13       ;; Deprecated
    14       filter-rest-argument!
    15       ;;
    16       length=0? length=1? length=2? length>1?
     16      length=0?
     17      length=1?
     18      length=2?
     19      length>1?
    1720      ensure-list
    1821      not-null?
    1922      alist-inverse-ref
    20       alist-delete/count alist-delete!/count
    21       alist-delete-first alist-delete-first!
    22       unzip-alist zip-alist
     23      alist-delete/count
     24      alist-delete!/count
     25      alist-delete-first
     26      alist-delete-first!
     27      unzip-alist
     28      zip-alist
    2329      filter-rest-argument!
    2430      fixup-extended-lambda-list-rest
    2531      fixup-extended-lambda-list-optional
    2632      fixup-extended-lambda-list
    27       ; Deprecated
    28       alist-delete*) ) )
     33      ;; Deprecated
     34      filter-rest-argument!
     35      alist-delete*
     36      shift!
     37      unshift!) ) )
    2938
    3039;;;
     
    235244                  "test argument not a procedure or list" testarg)])])
    236245    (filter! pred args) ) )
     246
     247
     248;;; Handy little things:
     249
     250(define (shift! lst #!optional default)
     251  (if (null? lst)
     252      default
     253      (begin
     254        (##sys#check-pair lst 'shift!)
     255        (let ([x (car lst)]
     256              [d (cdr lst)] )
     257          (##sys#check-pair d 'shift!)
     258          (set-car! lst (car d))
     259          (set-cdr! lst (cdr d))
     260          x) ) ) )
     261
     262(define (unshift! x lst)
     263  (##sys#check-pair lst 'unshift!)
     264  (set-car! lst x)
     265  (set-cdr! lst (cons (car lst) (cdr lst)))
     266  lst )
  • release/3/misc-extn/trunk/misc-extn-posix.scm

    r5437 r8075  
    99;; .setup w/ a 'try-compile' & then pass info as a '-feature SYMBOL'.
    1010
    11 (use srfi-1 srfi-13 utils posix)
    12 (use misc-extn-list)
     11(use posix)
     12(use misc-extn-directory) ; For Now
    1313
    1414(eval-when (compile)
    1515  (declare
     16    (usual-integrations)
    1617        (inline)
    1718        (fixnum)
    1819                (no-procedure-checks)
    1920                (no-bound-checks)
    20     (import
    21       ##core#immutable
    22       ##sys#update-errno
    23       ##sys#error
    24       ##sys#posix-error)
    2521    (bound-to-procedure
    2622      ##core#immutable
    2723      ##sys#update-errno
    2824      ##sys#error
    29       ##sys#posix-error)
     25      #;##sys#posix-error)
    3026        (export
    31           ; deprecated
    32                 which-command-directory
    33                 ;
    3427      priority/process
    3528      priority/process-group
     
    6558      open-pty
    6659      login-tty
    67       replace-fileno
    68       create-directory/parents
    69                 create-pathname-directory
    70                 make-program-filename
    71                 file-exists/directory?
    72                 find-file-pathnames
    73                 find-program-pathnames
    74                 which-command-pathname
    75                 remove-dotfiles) ) )
     60      replace-fileno) ) )
    7661
    7762;;;
     
    8368       (##core#immutable '"this function is not available on this platform")) ) )
    8469
    85 ;;;
     70;;; Spawn Stuff
    8671
    8772#|
     
    11398posix_spawn_file_actions_addopen(posix_spawn_file_actions_t *restrict, int, const char *restrict, int, mode_t);
    11499
    115 ; FILE-ACTIONS init     
     100; FILE-ACTIONS init
    116101; FILE-ACTIONS destroy   FILE-ACTIONS
    117102; FILE-ACTIONS add       open FILE-ACTIONS FILENO PATH OPEN-FLAG MODE
     
    194179(cond-expand
    195180  [unix
     181
    196182    #>
    197183    #include <errno.h>
    198184    <#
    199185
    200     (define-foreign-variable _errno int "errno")
    201   ] [else
    202   ] )
     186    (define-foreign-variable _errno int "errno") ]
     187
     188  [else] )
    203189
    204190;; Process Priority
     
    206192(cond-expand
    207193  [unix
     194
    208195    #>
    209196    #include <sys/time.h>
     
    222209            (when (and (negative? res) (not (zero? _errno)))
    223210              (##sys#update-errno)
    224               (##sys#error 'scheduling-priority
    225                 "get priority failed" which who))
     211              (##sys#error 'scheduling-priority "get priority failed" which who))
    226212            res) ) ) )
    227213
     
    232218            (when (fx< res 0)
    233219              (##sys#update-errno)
    234               (##sys#error 'set-scheduling-priority!
    235                 "set priority failed" which who prio)) ) ) ) )
    236   ] [else
     220              (##sys#error 'set-scheduling-priority! "set priority failed" which who prio)) ) ) ) ) ]
     221
     222  [else
     223
    237224    (define priority/process (void))
    238225    (define priority/process-group (void))
    239226    (define priority/user (void))
    240227    (define-unimplemented scheduling-priority)
    241     (define-unimplemented set-scheduling-priority!)
    242   ] )
     228    (define-unimplemented set-scheduling-priority!) ] )
    243229
    244230;; Termios & Winsize Records
     
    246232(cond-expand
    247233  [unix
     234
    248235    #>
    249236    #include <termios.h>
     
    251238    <#
    252239
     240    ; ws_row        rows, in characters
     241    ; ws_col        columns, in characters
     242    ; ws_xpixel     horizontal size, in pixels
     243    ; ws_ypixel     vertical size, in pixels
     244
    253245    (define-foreign-record (winsize "struct winsize")
    254246      (rename: (cut string-translate* <> '(("ws_" . ""))))
    255247      (constructor: alloc-winsize)
    256248      (destructor: free-winsize)
    257       (unsigned-short  ws_row)        ; rows, in characters
    258       (unsigned-short  ws_col)        ; columns, in characters
    259       (unsigned-short  ws_xpixel)     ; horizontal size, pixels
    260       (unsigned-short  ws_ypixel) )   ; vertical size, pixels
     249      (unsigned-short  ws_row)
     250      (unsigned-short  ws_col)
     251      (unsigned-short  ws_xpixel)
     252      (unsigned-short  ws_ypixel) )
    261253
    262254    (define-foreign-type tcflag_t unsigned-long)
     
    267259    (cond-expand
    268260      [macosx
     261
     262        ; c_iflag                 input flags
     263        ; c_oflag                 output flags
     264        ; c_cflag                 control flags
     265        ; c_lflag                 local flags
     266        ; c_cc            control chars
     267        ; c_ispeed    input speed
     268        ; c_ospeed    output speed
     269
    269270        (define-foreign-record (termios "struct termios")
    270271          (rename: (cut string-translate* <> '(("c_" . ""))))
    271272          (constructor: alloc-termios)
    272273          (destructor: free-termios)
    273           (tcflag_t c_iflag)              ; input flags
    274           (tcflag_t c_oflag)              ; output flags
    275           (tcflag_t c_cflag)              ; control flags
    276           (tcflag_t c_lflag)              ; local flags
    277           (cc_t c_cc NCCS)                  ; control chars
    278           (speed_t c_ispeed)              ; input speed
    279           (speed_t c_ospeed) )    ; output speed
    280       ] [else
     274          (tcflag_t c_iflag)
     275          (tcflag_t c_oflag)
     276          (tcflag_t c_cflag)
     277          (tcflag_t c_lflag)
     278          (cc_t c_cc NCCS)
     279          (speed_t c_ispeed)
     280          (speed_t c_ospeed) ) ]
     281
     282      [else
     283
     284        ; c_iflag                 input flags
     285        ; c_oflag                 output flags
     286        ; c_cflag                 control flags
     287        ; c_lflag                 local flags
     288        ; c_cc            control chars
     289
    281290        (define-foreign-record (termios "struct termios")
    282291          (rename: (cut string-translate* <> '(("c_" . ""))))
    283292          (constructor: alloc-termios)
    284293          (destructor: free-termios)
    285           (tcflag_t c_iflag)              ; input flags
    286           (tcflag_t c_oflag)              ; output flags
    287           (tcflag_t c_cflag)              ; control flags
    288           (tcflag_t c_lflag)              ; local flags
    289           (cc_t c_cc NCCS) )              ; control chars
     294          (tcflag_t c_iflag)
     295          (tcflag_t c_oflag)
     296          (tcflag_t c_cflag)
     297          (tcflag_t c_lflag)
     298          (cc_t c_cc NCCS) )
     299
    290300        (define-unimplemented termios-ispeed)
    291301        (define-unimplemented termios-ispeed-set!)
    292302        (define-unimplemented termios-ospeed)
    293         (define-unimplemented termios-ospeed-set!)
    294     ])
    295   ] [else
     303        (define-unimplemented termios-ospeed-set!) ] ) ]
     304
     305  [else
     306
    296307    (define-unimplemented alloc-winsize)
    297308    (define-unimplemented free-winsize)
     
    319330    (define-unimplemented termios-cflag-set!)
    320331    (define-unimplemented termios-oflag-set!)
    321     (define-unimplemented termios-iflag-set!)
    322   ] )
     332    (define-unimplemented termios-iflag-set!) ] )
    323333
    324334;; Pseudo-tty
    325335
    326336#| Solaris open pty per pts(7D) manpage
     337
    327338    int    fdm fds;
    328339    char   *slavename;
     
    340351(cond-expand
    341352  [solaris
     353
    342354    (define-unimplemented open-pty)
    343     (define-unimplemented login-tty)
    344   ] [unix
     355    (define-unimplemented login-tty) ]
     356
     357  [unix
     358
    345359    #>
    346360    #if defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__)
     
    354368
    355369    (define open-pty
    356       (foreign-lambda int "openpty" (nonnull-pointer int) (nonnull-pointer int)
    357                                     c-string pointer pointer))
     370      (foreign-lambda int "openpty" (nonnull-c-pointer int) (nonnull-c-pointer int)
     371                                    c-string c-pointer c-pointer))
    358372
    359373    (define login-tty
    360       (foreign-lambda int "login_tty" int))
    361   ] [else
     374      (foreign-lambda int "login_tty" int)) ]
     375
     376  [else
     377
    362378    (define-unimplemented open-pty)
    363     (define-unimplemented login-tty)
    364   ] )
     379    (define-unimplemented login-tty) ] )
    365380
    366381;;
     
    370385    (duplicate-fileno fd sfd)
    371386    (file-close fd) ) )
    372 
    373 ;;; Directory Stuff
    374 
    375 ;; Ensure the directory exists.
    376 
    377 (define (create-directory/parents dir)
    378   (let loop ([dir dir])
    379     (when (and dir (not (directory? dir)))
    380       (loop (pathname-directory dir))
    381       (create-directory dir) ) ) )
    382 
    383 ;; Ensure the directory for the specified path exists.
    384 
    385 (define (create-pathname-directory pathname)
    386   (create-directory/parents (pathname-directory pathname)) )
    387 
    388 ;; Platform specific program filename.
    389 
    390 (define (make-program-filename bn)
    391   (cond-expand
    392     [windows
    393       (if (pathname-extension bn)
    394         bn
    395         (make-pathname #f bn ".exe"))]
    396     [else
    397       bn]) )
    398 
    399 ;; Pathname if file exists in directory.
    400 
    401 (define (file-exists/directory? fil #!optional dir)
    402   (let ([path (make-pathname dir fil)])
    403     (and (file-exists? path)
    404          path) ) )
    405 
    406 ;; List of all found pathnames.
    407 
    408 (define (find-file-pathnames fil . dirs)
    409   (let loop ([dirs dirs] [paths '()])
    410     (if (null? dirs)
    411       (not-null? paths)
    412       (let ([dir (car dirs)])
    413         (loop (cdr dirs)
    414           (append! paths
    415             (filter-map
    416               (cut file-exists/directory? fil <>)
    417               (ensure-list dir)))))) ) )
    418 
    419 (define (find-program-pathnames cmd . dirs)
    420   (apply find-file-pathnames
    421     (make-program-filename cmd)
    422     dirs) )
    423 
    424 ;; First found program pathname in path.
    425 
    426 (cond-expand
    427   [windows (define-constant PATH-DELIMITER ";")]
    428   [else (define-constant PATH-DELIMITER ":")])
    429 
    430 (define (which-command-pathname cmd #!optional (env-var "PATH"))
    431   (and-let* ([env-path (getenv env-var)]
    432              [paths
    433               (find-program-pathnames
    434                 cmd
    435                 (string-split env-path PATH-DELIMITER))])
    436     (first paths) ) )
    437 
    438 ;; Remove dot files from a directory list
    439 
    440 (define (remove-dotfiles files)
    441         (remove
    442                 (lambda (pn)
    443                         (string-prefix? "." (pathname-file pn)))
    444                 files) )
    445 
    446 ;; Deprecated
    447 
    448 (define which-command-directory which-command-pathname)
  • release/3/misc-extn/trunk/misc-extn.html

    r6202 r8075  
    346346<p>Mutable flonum decrement.</p></dd></div>
    347347<div class="subsection">
    348 <h4>Posix</h4>
    349 <div class="section">
    350 <h3>Usage</h3>(require-extension misc-extn-posix)</div>
    351 <dt class="definition"><strong>procedure:</strong> (replace-fileno NEW-FILENO KNOWN-FILENO)</dt>
    352 <dd>
    353 <p>Replaces the meaning of <tt>KNOWN-FILENO</tt> with <tt>NEW-FILENO</tt>. I/O Redirection.</p></dd>
     348<h4>Directories</h4>
     349<dt class="definition"><strong>procedure:</strong> (push-directory DIRECTORY)</dt>
     350<dd>
     351<p>Push the current directory and change to the <tt>DIRECTORY</tt>.</p></dd>
     352<dt class="definition"><strong>procedure:</strong> (pop-directory)</dt>
     353<dd>
     354<p>Pop the last directory and change to it.</p></dd>
     355<dt class="definition"><strong>procedure:</strong> (pop-toplevel-directory)</dt>
     356<dd>
     357<p>Pop the earliest directory and change to it.</p></dd>
    354358<dt class="definition"><strong>procedure:</strong> (create-directory/parents DIRECTORY)</dt>
    355359<dd>
     
    378382<p>Uses <code>make-program-filename</code> to make a filename.</p>
    379383<p>Does not ensure that the file is executable!</p></dd>
    380 <dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE </dt>
    381 <dd>
    382 <PATH>])
     384<dt class="definition"><strong>procedure:</strong> (which-command-pathname COMMAND-NAME [ENVIRONMENT-VARIABLE PATH])</dt>
     385<dd>
    383386<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>
    384387<p>Uses the platform specific PATH environment variable element separator - a semi-colon for Windows, &amp; a colon otherwise.</p>
    385 <p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></PATH></dd>
     388<p>Like the UNIX &quot;which COMMAND-NAME&quot; command.</p></dd>
    386389<dt class="definition"><strong>procedure:</strong> (remove-dotfiles FILES)</dt>
    387390<dd>
    388 <p>Remove dot files from a directory list. Useful with <code>glob</code>.</p></dd>
     391<p>Remove dot files from a directory list. Useful with <code>glob</code>.</p></dd></div>
     392<div class="subsection">
     393<h4>Posix</h4>
     394<div class="section">
     395<h3>Usage</h3>(require-extension misc-extn-posix)</div>
     396<div class="subsubsection">
     397<h5>File Descriptors</h5>
     398<dt class="definition"><strong>procedure:</strong> (replace-fileno NEW-FILENO KNOWN-FILENO)</dt>
     399<dd>
     400<p>Replaces the meaning of <tt>KNOWN-FILENO</tt> with <tt>NEW-FILENO</tt>. I/O Redirection.</p></dd></div>
    389401<div class="subsubsection">
    390402<h5>Scheduling Priority</h5>
     
    663675<h3>Version</h3>
    664676<ul>
     677<li>3.004 Added misc-extn-directory; moved file-exists/directory, find-file-pathnames, find-program-pathnames, whch-command-pathname, remove-dotfiles from misc-extn-posix.</li>
    665678<li>3.003 Added list macros. Deprecated alist-delete*, filter-rest-argument!. Added misc-extn-dsssl.</li>
    666679<li>3.002 Reverted to 3.0 behavior for unbound Wasn't a bug.</li>
  • release/3/misc-extn/trunk/misc-extn.meta

    r6205 r8075  
    1212        "misc-extn-record.scm"
    1313        "misc-extn-io.scm"
     14        "misc-extn-directory.scm"
    1415        "misc-extn-posix.scm"
    1516        "misc-extn-list.scm" "misc-extn-list-support.scm"
  • release/3/misc-extn/trunk/misc-extn.setup

    r6200 r8075  
    1616
    1717(install-dynld misc-extn-io *version* (documentation "misc-extn.html"))
     18(install-dynld misc-extn-directory *version* (documentation "misc-extn.html"))
    1819(install-dynld misc-extn-posix *version* (documentation "misc-extn.html"))
    1920
Note: See TracChangeset for help on using the changeset viewer.