Changeset 2816 in project


Ignore:
Timestamp:
01/10/07 18:32:31 (14 years ago)
Author:
Kon Lovett
Message:

Added priority routines.

Location:
misc-extn
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • misc-extn/misc-extn-eggdoc.scm

    r2600 r2816  
    3232  (print name " " foo #\newline))
    3333
    34 (stiff-set! x 1 y 2)    ; x = 1 y = 2
    35 (fluid-set! x y y x)    ; x = 2 y = 1
    36 (swap-set! x y)                         ; x = 1 y = 2
     34(stiff-set! x 1 y 2)  ; x = 1 y = 2
     35(fluid-set! x y y x)  ; x = 2 y = 1
     36(swap-set! x y)       ; x = 1 y = 2
    3737EOF
    3838)))
     
    4444    (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    4545    (history
    46         (version "2.5" "Removed defined-symbol? & make-log-function, added alist-delete*, shift!/set")
    47         (version "2.4" "Bug fix for defined-symbol?")
    48         (version "2.3" "Added undefined & unbound stuff")
    49         (version "2.2" "Added 'chain-implicit-exit-handler'")
    50         (version "2.1" "Added 'whennot', 'inc', 'dec','create-pathname-directory'")
    51         (version "2.0" "Added 'define-inline-unchecked-record-type'")
    52         (version "1.9" "Rename ++f* -> f*++, remove mu & nu; me stupid")
    53         (version "1.8" "Moved procedures to own extension")
    54         (version "1.7" "Exports, additions")
    55         (version "1.6" "More stuff, rename fp++, etc -> ++fp")
    56         (version "1.5" "Added alist-delete-first")
    57         (version "1.4" "Added mu, nu, moved looping constructs to miscmacros")
    58         (version "1.3" "Removed use of define-syntax")
    59         (version "1.2" "Added assure, nl, rename set*! to stiff-set!, fp++, etc.")
    60         (version "1.1" "Added plain repeat, assoc macros signal errors")
    61         (version "1.0" "Initial release"))
     46      (version "2.6" "Added priority routines to posix extension.")
     47      (version "2.5" "Removed defined-symbol? & make-log-function, added alist-delete*, shift!/set, unzip-alist")
     48      (version "2.4" "Bug fix for defined-symbol?")
     49      (version "2.3" "Added undefined & unbound stuff")
     50      (version "2.2" "Added 'chain-implicit-exit-handler'")
     51      (version "2.1" "Added 'whennot', 'inc', 'dec','create-pathname-directory'")
     52      (version "2.0" "Added 'define-inline-unchecked-record-type'")
     53      (version "1.9" "Rename ++f* -> f*++, remove mu & nu; me stupid")
     54      (version "1.8" "Moved procedures to own extension")
     55      (version "1.7" "Exports, additions")
     56      (version "1.6" "More stuff, rename fp++, etc -> ++fp")
     57      (version "1.5" "Added alist-delete-first")
     58      (version "1.4" "Added mu, nu, moved looping constructs to miscmacros")
     59      (version "1.3" "Removed use of define-syntax")
     60      (version "1.2" "Added assure, nl, rename set*! to stiff-set!, fp++, etc.")
     61      (version "1.1" "Added plain repeat, assoc macros signal errors")
     62      (version "1.0" "Initial release"))
    6263
    6364    (usage)
     
    6869      (subsection "Record Types"
    6970
    70                                 (macro "(define-unchecked-record-type T CTOR PRED [SLOT ...])"
    71                                         (p "SRFI-9 '(define-record-type T CTOR PRED [SLOT ...])', "
    72                                         "except no checks are made for correct record type before slot "
    73                                         "access, and the record type symbol is not defined.")
    74 
    75                                         (p "For use when slot access is attempted " (i "only") " after "
    76                                         "determining the correct record type explicitly. Do " (i "not") " "
    77                                         "make constructed slot access procedures part of a public "
    78                                         "API."))
    79 
    80                                 (macro "(define-inline-unchecked-record-type T CTOR PRED [SLOT ...])"
    81                                         (p "SRFI-9 '(define-record-type T CTOR PRED [SLOT ...])', "
    82                                         "except no checks are made for correct record type before slot "
    83                                         "access, the record type symbol is not defined, and  "
    84                                         "procedures are inline.")
    85 
    86                                         (p "For use when slot access is attempted " (i "only") " after "
    87                                         "determining the correct record type explicitly."))
    88         )
     71        (macro "(define-unchecked-record-type T CTOR PRED [SLOT ...])"
     72          (p "SRFI-9 '(define-record-type T CTOR PRED [SLOT ...])', "
     73          "except no checks are made for correct record type before slot "
     74          "access, and the record type symbol is not defined.")
     75
     76          (p "For use when slot access is attempted " (i "only") " after "
     77          "determining the correct record type explicitly. Do " (i "not") " "
     78          "make constructed slot access procedures part of a public "
     79          "API."))
     80
     81        (macro "(define-inline-unchecked-record-type T CTOR PRED [SLOT ...])"
     82          (p "SRFI-9 '(define-record-type T CTOR PRED [SLOT ...])', "
     83          "except no checks are made for correct record type before slot "
     84          "access, the record type symbol is not defined, and  "
     85          "procedures are inline.")
     86
     87          (p "For use when slot access is attempted " (i "only") " after "
     88          "determining the correct record type explicitly."))
     89      )
    8990
    9091      (subsection "Control Forms"
    9192
    9293        (macro "(whennot CONDITION [BODY...])"
    93                 (p "Same as " (code "(unless CONDITION [BODY...])") "."))
    94 
    95                                 (macro "(errorf [ID] FORMAT ARGS ...)"
    96                                         (p "Same as '(error [ID] (sprintf FORMAT ARGS ...))'.")
    97 
    98                                         (p "The actual argument for the returned procedure is to be a "
    99                                         "procedure which will be applied with the evaluated expressions "
    100                                         "as the actual argument list."))
     94          (p "Same as " (code "(unless CONDITION [BODY...])") "."))
     95
     96        (macro "(errorf [ID] FORMAT ARGS ...)"
     97          (p "Same as '(error [ID] (sprintf FORMAT ARGS ...))'.")
     98
     99          (p "The actual argument for the returned procedure is to be a "
     100          "procedure which will be applied with the evaluated expressions "
     101          "as the actual argument list."))
    101102
    102103        (macro "(swap-set! VAR1 VAR2)"
    103                 (p "Swap settings of " (tt "VAR1") " & " (tt "VAR2") "."))
     104          (p "Swap settings of " (tt "VAR1") " & " (tt "VAR2") "."))
    104105
    105106        (macro "(fluid-set! VAR VAL ...)"
     
    122123
    123124        (macro "(assure EXPRESSION ERROR-ARGUMENT ...)"
    124                 (p "When " (tt "EXPRESSION") " yields " (code "#f") " invoke "
    125                 (code "(error ERROR-ARGUMENT ...)") "."))
    126 
    127                 (usage "(use misc-extn-procs)")
    128 
    129         (procedure "(chain-implicit-exit-handler THUNK)"
    130                 (p "Adds the " (tt "THUNK") " to the front of the "
    131                 "implicit-exit-handler chain.") )
    132                         )
     125          (p "When " (tt "EXPRESSION") " yields " (code "#f") " invoke "
     126          (code "(error ERROR-ARGUMENT ...)") "."))
     127
     128        (usage "(use misc-extn-procs)")
     129
     130        (procedure "(chain-implicit-exit-handler THUNK)"
     131          (p "Adds the " (tt "THUNK") " to the front of the "
     132          "implicit-exit-handler chain.") )
     133      )
    133134
    134135      (subsection "Lists"
    135136
    136137        (macro "(length=0? LIST)"
    137                 (p "List of length zero?"))
     138          (p "List of length zero?"))
    138139
    139140        (macro "(length=1? LIST)"
    140                 (p "List of length one?"))
     141          (p "List of length one?"))
    141142
    142143        (macro "(length=2? LIST)"
    143                 (p "List of length two?"))
     144          (p "List of length two?"))
    144145
    145146        (macro "(length>1? LIST)"
    146                 (p "List of length greater than one?"))
     147          (p "List of length greater than one?"))
    147148
    148149        (macro "(not-null? LIST)"
    149                 (p "Returns " (code "#f") " if the given " (tt "LIST") " is empty, and "
    150                 (tt "LIST") " otherwise."))
     150          (p "Returns " (code "#f") " if the given " (tt "LIST") " is empty, and "
     151          (tt "LIST") " otherwise."))
    151152
    152153        (macro "(shift!/set SYM [DEFAULT])"
    153                 (p "Like " (code "shift!") " in the utils unit but assigns the "
    154                 "variable " (tt "SYM") " the " (code "'()") " after shifting from a "
    155                 "list of length 1."))
     154          (p "Like " (code "shift!") " in the utils unit but assigns the "
     155          "variable " (tt "SYM") " the " (code "'()") " after shifting from a "
     156          "list of length 1."))
    156157
    157158        (macro "(assoc-def KEY ALIST [TEST] [DEFAULT])"
     
    167168          "signaled when not found."))
    168169
    169                 (usage "(use misc-extn-procs)")
    170 
    171         (procedure "(filter-rest-argument! REST-LIST [PREDICATE | LIST-OF-KEYWORD])"
    172                 (p "Destructively remove any keywords & keyword+value items from a "
    173                 (code "#!rest") " argument list.")
    174 
    175                 (p "When the optional predicate is supplied it must return "
    176                 (code "#t") " or " (code "#f") " indicating whether the item "
    177                 "is to kept or removed. The predicate takes the current item.")
    178 
    179                 (p "When the optional keyword list is supplied only keywords & "
    180                 "keyword+value items from the list are removed."))
    181 
    182                                 (procedure "(alist-inverse-ref VALUE ALIST [EQUALITY? eqv?] [DEFAULT #f])"
    183                                         (p "Returns the first key associated with " (tt "VALUE") " in "
    184                                         "the " (tt "ALIST") " using the " (tt "EQUALITY?") " predicate, "
    185                                         "else " (tt "DEFAULT") "."))
    186 
    187                                 (procedure "(alist-delete* KEY ALIST [COUNT [EQUALITY?]])"
    188                                         (p "Deletes the first (tt "COUNT") associations from alist "
    189                                         (tt "ALIST") "with the given key " (tt "KEY") ", using key-comparison "
    190                                         "procedure " (tt "EQUALITY?") ". The dynamic order in which the "
    191                                         "various applications of equality are made is from the alist "
    192                                         "head to the tail.")
    193 
    194                                         (p "Returns a new alist. The alist is not disordered - elements that appear "
    195                                         "in the result alist occur in the same order as they occur in "
    196                                         "the argument alist.")
    197 
    198                                         (p "The equality procedure is used to compare the element "
    199                                         "keys, 'key[i: 0 <= i < (length ALIST)]', of the alist's "
    200                                         "entries to the key parameter in this way: '(EQUALITY? KEY "
    201                                         "key[i])'.")
    202 
    203                                         (p (tt "COUNT") " defaults to essentially, infinity, and " (tt "EQUALITY?")
    204                                         " defaults to " (code "equal?") ".") )
    205 
    206                                 (procedure "(alist-delete-first KEY ALIST [EQUALITY?])"
    207                                         (p "Returns " (code "(alist-delete* KEY ALIST 1 [EQUALITY?])") ".") )
     170        (usage "(use misc-extn-procs)")
     171
     172        (procedure "(filter-rest-argument! REST-LIST [PREDICATE | LIST-OF-KEYWORD])"
     173          (p "Destructively remove any keywords & keyword+value items from a "
     174          (code "#!rest") " argument list.")
     175
     176          (p "When the optional predicate is supplied it must return "
     177          (code "#t") " or " (code "#f") " indicating whether the item "
     178          "is to kept or removed. The predicate takes the current item.")
     179
     180          (p "When the optional keyword list is supplied only keywords & "
     181          "keyword+value items from the list are removed."))
     182
     183        (procedure "(alist-inverse-ref VALUE ALIST [EQUALITY? eqv?] [DEFAULT #f])"
     184          (p "Returns the first key associated with " (tt "VALUE") " in "
     185          "the " (tt "ALIST") " using the " (tt "EQUALITY?") " predicate, "
     186          "else " (tt "DEFAULT") "."))
     187
     188        (procedure "(alist-delete* KEY ALIST [COUNT [EQUALITY?]])"
     189          (p "Deletes the first (tt "COUNT") associations from alist "
     190          (tt "ALIST") "with the given key " (tt "KEY") ", using key-comparison "
     191          "procedure " (tt "EQUALITY?") ". The dynamic order in which the "
     192          "various applications of equality are made is from the alist "
     193          "head to the tail.")
     194
     195          (p "Returns a new alist. The alist is not disordered - elements that appear "
     196          "in the result alist occur in the same order as they occur in "
     197          "the argument alist.")
     198
     199          (p "The equality procedure is used to compare the element "
     200          "keys, 'key[i: 0 <= i < (length ALIST)]', of the alist's "
     201          "entries to the key parameter in this way: '(EQUALITY? KEY "
     202          "key[i])'.")
     203
     204          (p (tt "COUNT") " defaults to essentially, infinity, and " (tt "EQUALITY?")
     205          " defaults to " (code "equal?") ".") )
     206
     207        (procedure "(alist-delete-first KEY ALIST [EQUALITY?])"
     208          (p "Returns " (code "(alist-delete* KEY ALIST 1 [EQUALITY?])") ".") )
     209
     210        (procedure "(unzip-alist ALIST)"
     211          (p "Returns 2 values, a list of the keys & a list of the values from
     212          the " (tt "ALIST") ".") )
    208213      )
    209214
    210215      #;(subsection "Predicate"
    211216
    212         (macro "(chain? EXPR1 OP1 EXPR2 [OP3 EXPR3 ...])"
    213                 (p "Translates to " (code "(and (OPR1 EXPR1 EXPR2) (OP3 EXPR2 EXPR3) ...)") " "
    214                 "minus the duplicated evaluation."))
     217        (macro "(chain? EXPR1 OP1 EXPR2 [OP3 EXPR3 ...])"
     218          (p "Translates to " (code "(and (OPR1 EXPR1 EXPR2) (OP3 EXPR2 EXPR3) ...)") " "
     219          "minus the duplicated evaluation."))
    215220      )
    216221
    217222      (subsection "Structure"
    218223
    219         (macro "(define-structure NAME EXPORTS [BODY ...])"
    220                 (p "Define the symbol " (tt "NAME") " as a structure "
    221                 "with the export list " (tt "EXPORTS") " and " (tt "BODY") "."))
     224        (macro "(define-structure NAME EXPORTS [BODY ...])"
     225          (p "Define the symbol " (tt "NAME") " as a structure "
     226          "with the export list " (tt "EXPORTS") " and " (tt "BODY") "."))
    222227      )
    223228
     
    269274      (subsection "Posix"
    270275
    271                 (usage "(use misc-extn-posix)")
     276        (usage "(use misc-extn-posix)")
     277
     278                                (p "Scheduling Priority Arguments")
     279                                (symbol-table
     280                                        (describe priority/process
     281                                                "Process WHICH - WHO is 0 for current process or a process identifier.")
     282                                        (describe priority/process-group
     283                                                "Process Group WHICH - WHO is 0 for current process group or a process group identifier.")
     284                                        (describe priority/user
     285                                                "User WHICH - WHO is 0 for current user or a user identifier.")
     286                                        (describe PRIORITY
     287                                                "An integer [-20 20].") )
     288                                (br)
     289
     290                                (procedure "(scheduling-priority WHICH WHO)"
     291                                        (p "Returns the priority of " (tt "WHO") " of kind " (tt "WHICH") ".") )
     292
     293                                (procedure "(set-scheduling-priority! WHICH WHO PRIORITY)"
     294                                        (p "Sets the priority of " (tt "WHO") " of kind " (tt "WHICH") " to "
     295                                        (tt "PRIORITY") ".") )
    272296
    273297        (procedure "(create-pathname-directory PATHNAME)"
     
    287311      (subsection "Symbol"
    288312
    289                 (usage "(use misc-extn)")
    290 
    291                                 (macro "(unbound-value)"
    292                                         (p "Returns the value representing \"unbound\".") )
    293 
    294                                 (macro "(unbound-value? OBJECT)"
    295                                         (p "Is the " (tt "OBJECT") " the unbound value?") )
    296 
    297                                 (macro "(unbound? SYMBOL)"
    298                                         (p "Is the " (tt "SYMBOL") " unbound?") )
    299 
    300                                 (macro "(symbol-value SYMBOL [DEFAULT #f])"
    301                                         (p "Returns the " (tt "SYMBOL") " binding when bound, "
    302                                         "otherwise the " (tt "DEFAULT") ".") )
    303 
    304                                 (macro "(undefined-value)"
    305                                         (p "Returns the value representing \"undefined\".") )
    306 
    307                                 (macro "(undefined-value? OBJECT)"
    308                                         (p "Is the " (tt "OBJECT") " the undefined value?") )
    309 
    310                                 (macro "(undefined? OBJECT)"
    311                                         (p "Is the " (tt "OBJECT") " the undefined value?") )
    312 
    313                 (usage "(use misc-extn-procs)")
     313        (usage "(use misc-extn)")
     314
     315        (macro "(unbound-value)"
     316          (p "Returns the value representing \"unbound\".") )
     317
     318        (macro "(unbound-value? OBJECT)"
     319          (p "Is the " (tt "OBJECT") " the unbound value?") )
     320
     321        (macro "(unbound? SYMBOL)"
     322          (p "Is the " (tt "SYMBOL") " unbound?") )
     323
     324        (macro "(symbol-value SYMBOL [DEFAULT #f])"
     325          (p "Returns the " (tt "SYMBOL") " binding when bound, "
     326          "otherwise the " (tt "DEFAULT") ".") )
     327
     328        (macro "(undefined-value)"
     329          (p "Returns the value representing \"undefined\".") )
     330
     331        (macro "(undefined-value? OBJECT)"
     332          (p "Is the " (tt "OBJECT") " the undefined value?") )
     333
     334        (macro "(undefined? OBJECT)"
     335          (p "Is the " (tt "OBJECT") " the undefined value?") )
     336
     337        (usage "(use misc-extn-procs)")
    314338
    315339        (procedure "(make-qualified-symbol NAMESPACE SYMBOL)"
    316340          (p "Returns the Chicken namespace qualified " (tt "SYMBOL") " for the "
    317341          (tt "NAMESPACE") ".")
    318          
     342
    319343          (p "An exception is generated when the " (tt "NAMESPACE")
    320344          " length exceeds the system limit.") )
     
    326350      (subsection "Input/Output"
    327351
    328                 (usage "(use misc-extn-procs)")
     352        (usage "(use misc-extn-procs)")
    329353
    330354        (procedure "(cout EXPR ...)"
     
    347371     )
    348372
    349                 (section "Contributions"
    350 
    351                         (p "William Annis - hash-let.")
    352 
    353                         (p "Oleg Kiselyov's Standard Scheme \"Prelude\" - ++, ...")
    354                 )
    355 
    356                 (examples ,examples)
    357 
    358                 (section "License" (pre ,license))
     373    (section "Contributions"
     374
     375      (p "William Annis - hash-let.")
     376
     377      (p "Oleg Kiselyov's Standard Scheme \"Prelude\" - ++, ...")
     378    )
     379
     380    (examples ,examples)
     381
     382    (section "License" (pre ,license))
    359383  )
    360384))
    361385
    362386(eggdoc->html doc
    363         `(,@(eggdoc:make-stylesheet doc)
    364                 (constant *macro* . ,eggdoc:make-defsig)))
     387  `(,@(eggdoc:make-stylesheet doc)
     388    (constant *macro* . ,eggdoc:make-defsig)))
  • misc-extn/misc-extn-posix.scm

    r1878 r2816  
    66(eval-when (compile)
    77  (declare
    8         (not usual-integrations ; unneeded since not recognized
    9                 string-prefix?)
    108        (inline)
     9        (fixnum)
     10                (no-procedure-checks)
     11                (no-bound-checks)
     12    (import
     13      ##sys#update-errno
     14      ##sys#error)
     15    (bound-to-procedure
     16      ##sys#update-errno
     17      ##sys#error)
    1118        (export
     19      priority/process
     20      priority/process-group
     21      priority/user
     22      scheduling-priority
     23      set-scheduling-priority!
    1224                create-pathname-directory
    13                 remove-dotfiles)
    14         )
     25                remove-dotfiles) ) )
    1526
    16         (cond-expand
    17                 [paranoia]
    18                 [else
    19                         (declare
    20                                 (no-procedure-checks)
    21                                 #;(no-argc-checks)
    22                                 (no-bound-checks)
    23         )])
     27;;;
     28
     29#+unix
     30#>
     31#include <errno.h>
     32#include <sys/time.h>
     33#include <sys/resource.h>
     34<#
     35
     36#+unix
     37(begin
     38
     39  (define-foreign-variable _errno int "errno")
     40 
     41  (define priority/process (foreign-value "PRIO_PROCESS" int))
     42  (define priority/process-group (foreign-value "PRIO_PGRP" int))
     43  (define priority/user (foreign-value "PRIO_USER" int))
     44 
     45  (define scheduling-priority
     46    (let ([get-priority (foreign-lambda int getpriority int int)])
     47      (lambda (which who)
     48        (set! _errno 0)
     49        (let ([res (get-priority which who)])
     50          (when (and (fx< res 0) (not (fx= _errno 0)))
     51            (##sys#update-errno)
     52            (##sys#error 'scheduling-priority "get priority failure" which who))
     53          res) ) ) )
     54 
     55  (define set-scheduling-priority!
     56    (let ([set-priority! (foreign-lambda int setpriority int int int)])
     57      (lambda (which who prio)
     58        (let ([res (set-priority! which who prio)])
     59          (when (fx< res 0)
     60            (##sys#update-errno)
     61            (##sys#error 'set-scheduling-priority! "set priority failure" which who prio))
     62          (void)) ) ) )
     63)
     64
     65#+windows
     66(begin
     67  (define priority/process (void))
     68  (define priority/process-group (void))
     69  (define priority/user (void))
     70  (define (scheduling-priority which who)
     71    (warning 'scheduling-priority "unsupported on Windows") )
     72  (define (set-scheduling-priority! which who prio)
     73    (warning 'set-scheduling-priority! "unsupported on Windows") )
    2474)
    2575
  • misc-extn/misc-extn-procs.scm

    r2600 r2816  
    66(eval-when (compile)
    77  (declare
    8         (fixnum)
    9         (inline)
    10         (export
    11                 chain-implicit-exit-handler
    12                 alist-inverse-ref alist-delete* alist-delete-first
    13                 filter-rest-argument!
    14                         cout cerr nl
    15                         identify-error
    16                         make-qualified-symbol qualified-symbol?)
    17         )
    18 
    19         (cond-expand
    20                 [paranoia]
    21                 [else
    22                         (declare
    23                                 (no-procedure-checks)
    24                                 #;(no-argc-checks)
    25                                 (no-bound-checks)
    26         )])
    27 )
     8    (fixnum)
     9    (inline)
     10    (no-procedure-checks)
     11    (no-bound-checks)
     12    (export
     13      chain-implicit-exit-handler
     14      alist-inverse-ref alist-delete* alist-delete-first unzip-alist
     15      filter-rest-argument!
     16      cout cerr nl
     17      identify-error
     18      make-qualified-symbol qualified-symbol?) ) )
    2819
    2920;;;
     
    3627
    3728(define (chain-implicit-exit-handler thunk)
    38         (let ([chained (implicit-exit-handler)])
    39                 (implicit-exit-handler
    40                         (lambda ()
    41                                 (thunk)
    42                                 (chained)) ) ) )
     29  (let ([chained (implicit-exit-handler)])
     30    (implicit-exit-handler
     31      (lambda ()
     32        (thunk)
     33        (chained)) ) ) )
    4334
    4435;; Remove any keywords & keyword-value pairs from a #!rest argument.
    4536
    4637(define (filter-rest-argument! args #!optional testarg)
    47         (let* (
    48                         [make-pred
    49                                 (lambda (itmtst)
    50                                         (let ([key? #f])
    51                                                 (lambda (arg)
    52                                                         (cond
    53                                                                 [key?
    54                                                                         (set! key? #f)
    55                                                                         #f]
    56                                                                 [(keyword? arg)
    57                                                                         (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
    58                                                                 [else
    59                                                                         #t]))))]
    60                         [pred
    61                                 (cond
    62                                         [(procedure? testarg)
    63                                                 testarg]
    64                                         [(list? testarg)
    65                                                 (make-pred memq)]
    66                                         [(not testarg)
    67                                                 (make-pred (lambda (arg lst) #t))]
    68                                         [else
    69                                                 (error 'filter-rest-argument! "test argument not a procedure or list" testarg)])])
    70                 (filter! pred args) ) )
     38  (let* (
     39      [make-pred
     40        (lambda (itmtst)
     41          (let ([key? #f])
     42            (lambda (arg)
     43              (cond
     44                [key?
     45                  (set! key? #f)
     46                  #f]
     47                [(keyword? arg)
     48                  (or (not (itmtst arg testarg)) (begin (set! key? #t) #f))]
     49                [else
     50                  #t]))))]
     51      [pred
     52        (cond
     53          [(procedure? testarg)
     54            testarg]
     55          [(list? testarg)
     56            (make-pred memq)]
     57          [(not testarg)
     58            (make-pred (lambda (arg lst) #t))]
     59          [else
     60            (error 'filter-rest-argument! "test argument not a procedure or list" testarg)])])
     61    (filter! pred args) ) )
    7162
    7263;; Searchs the alist from back to front.
    7364
    7465(define (alist-inverse-ref val alist #!optional (cmp eqv?) default)
    75         (let ([cell (rassoc val alist cmp)])
    76                 (or (and cell (car cell)) default)))
     66  (let ([cell (rassoc val alist cmp)])
     67    (or (and cell (car cell)) default)))
    7768
    7869;; Remove 1st count matching elements from the alist
    7970
    8071(define (alist-delete* key al #!optional (cnt 1073741823) (cmp equal?))
    81         (unless (procedure? cmp)
    82                 (error 'alist-delete* "compare must be a procedure" cmp))
    83         (unless (integer? cnt)
    84                 (error 'alist-delete* "count must be an integer" cnt))
    85         (let loop ([al al] [cnt cnt] [oal '()])
    86                 (cond
    87                         [(null? al)
    88                                 (reverse! oal)]
    89                         [(pair? al)
    90                                 (let ([elm (car al)]
    91                                                         [nxt (cdr al)])
    92                                         (if (pair? elm)
    93                                                 (if (positive? cnt)
    94                                                         (if (cmp key (car elm))
    95                                                                 (loop nxt (sub1 cnt) oal)
    96                                                                 (loop nxt cnt (cons elm oal)))
    97                                                         (loop nxt 0 (cons elm oal)))
    98                                                 (error 'alist-delete* "improper association list item" elm)))]
    99                         [else
    100                                 (error 'alist-delete* "improper association list" al)]) ) )
     72  (unless (procedure? cmp)
     73    (error 'alist-delete* "compare must be a procedure" cmp))
     74  (unless (integer? cnt)
     75    (error 'alist-delete* "count must be an integer" cnt))
     76  (let loop ([al al] [cnt cnt] [oal '()])
     77    (cond
     78      [(null? al)
     79        (reverse! oal)]
     80      [(pair? al)
     81        (let ([elm (car al)]
     82              [nxt (cdr al)])
     83          (if (pair? elm)
     84            (if (positive? cnt)
     85              (if (cmp key (car elm))
     86                (loop nxt (sub1 cnt) oal)
     87                (loop nxt cnt (cons elm oal)))
     88              (loop nxt 0 (cons elm oal)))
     89            (error 'alist-delete* "improper association list item" elm)))]
     90      [else
     91        (error 'alist-delete* "improper association list" al)]) ) )
    10192
    10293(define (alist-delete-first key al #!optional (cmp equal?))
    103         (alist-delete* key al 1 cmp) )
     94  (alist-delete* key al 1 cmp) )
     95
     96;;
     97
     98(define (unzip-alist alist)
     99  (let loop ([alist alist] [keys '()] [vals '()])
     100    (if (null? alist)
     101      (values (reverse! keys) (reverse! vals))
     102      (let ([elm (car alist)])
     103        (if (pair? elm)
     104          (loop (cdr alist) (cons (car elm) keys) (cons (cdr elm) vals))
     105          (error 'unzip-alist "improper assocication list" elm)) ) ) ) )
    104106
    105107;; Like cout << arguments << args
     
    108110
    109111(define (cout . args)
    110         (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
     112  (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
    111113
    112114(define (cerr . args)
    113         (let ([port (current-error-port)])
    114                 (for-each (lambda (x) (if (procedure? x) (x port) (display x port))) args)))
     115  (let ([port (current-error-port)])
     116    (for-each (lambda (x) (if (procedure? x) (x port) (display x port))) args)))
    115117
    116118;; The newline character as a string
     
    121123
    122124(define (identify-error msg . args)
    123         (let ([port (current-error-port)])
    124                 (display "Error: " port)
    125                 (when (symbol? msg)
    126                         (let ([caller msg])
    127                                 (set! msg
    128                                         (let ([msg (and (pair? args) (car args))])
    129                                                 (when msg
    130                                                         (set! args (cdr args)))
    131                                                 msg))
    132                                 (display "(" port) (display caller port) (display ") " port)))
    133                 (when msg
    134                         (display msg port))
    135                 (unless (null? args)
    136                         (for-each (lambda (arg) (newline port) (write arg port)) args))
    137                 (newline port)))
     125  (let ([port (current-error-port)])
     126    (display "Error: " port)
     127    (when (symbol? msg)
     128      (let ([caller msg])
     129        (set! msg
     130          (let ([msg (and (pair? args) (car args))])
     131            (when msg
     132              (set! args (cdr args)))
     133            msg))
     134        (display "(" port) (display caller port) (display ") " port)))
     135    (when msg
     136      (display msg port))
     137    (unless (null? args)
     138      (for-each (lambda (arg) (newline port) (write arg port)) args))
     139    (newline port)))
    138140
    139141;; Make a Chicken namespace qualified symbol.
     
    142144
    143145(define (make-qualified-symbol namespace symbol)
    144         (let* ([ns (->string namespace)]
    145                                 [nsl (string-length ns)])
    146                 (if (and (<= 1 nsl NAMESPACE-MAX-ID-LEN))
    147                         (##sys#intern-symbol
    148                                 (##sys#string-append
    149                                         (##sys#string-append (string (integer->char nsl)) ns)
    150                                         (->string symbol)))
    151                         (abort
    152                                 (make-composite-condition
    153                                         (make-property-condition
    154                                                 'exn
    155                                                 'message "invalid namespace identifier length"
    156                                                 'location 'make-qualified-symbol
    157                                                 'arguments (list namespace symbol))
    158                                         (make-property-condition
    159                                                 'syntax))) ) ) )
     146  (let* ([ns (->string namespace)]
     147        [nsl (string-length ns)])
     148    (if (and (<= 1 nsl NAMESPACE-MAX-ID-LEN))
     149      (##sys#intern-symbol
     150        (##sys#string-append
     151          (##sys#string-append (string (integer->char nsl)) ns)
     152          (->string symbol)))
     153      (abort
     154        (make-composite-condition
     155          (make-property-condition
     156            'exn
     157            'message "invalid namespace identifier length"
     158            'location 'make-qualified-symbol
     159            'arguments (list namespace symbol))
     160          (make-property-condition
     161            'syntax))) ) ) )
    160162
    161163(define (qualified-symbol? sym)
    162         (not (not (##sys#qualified-symbol-prefix sym))) )
     164  (not (not (##sys#qualified-symbol-prefix sym))) )
  • misc-extn/misc-extn.setup

    r2600 r2816  
    11(include "setup-header")
    22
    3 (install-syntax+docu misc-extn "2.4")
     3(install-syntax+docu misc-extn "2.6")
    44
    5 (install-dynld misc-extn-procs "2.4" (documentation "misc-extn.html"))
     5(install-dynld misc-extn-procs "2.6" (documentation "misc-extn.html"))
    66
    7 (install-dynld misc-extn-posix "2.4" (documentation "misc-extn.html"))
     7(install-dynld misc-extn-posix "2.6" (documentation "misc-extn.html"))
  • misc-extn/setup-header.scm

    r1812 r2816  
    1313
    1414(define (->symbol obj)
    15         (if (string? obj) (string->symbol obj) obj) )
     15  (if (string? obj) (string->symbol obj) obj) )
    1616
    1717(define (make-filename bn . en)
     
    3535(define (parse-optionals opt)
    3636
    37         #;(define (string-drop-first str)
    38                 (list->string (cdr (string->list str))) )
     37  #;(define (string-drop-first str)
     38    (list->string (cdr (string->list str))) )
    3939
    40         #;(define (symbol-drop-first sym)
    41                 (string->symbol (string-drop-first (symbol->string sym))) )
     40  #;(define (symbol-drop-first sym)
     41    (string->symbol (string-drop-first (symbol->string sym))) )
    4242
    43         (let ([cmp-args '()] [rqr@run '()] [opt-args '()])
    44                 (let loop ([lst opt])
    45                         (if (null? lst)
    46                                 (values (reverse cmp-args) rqr@run opt-args)
    47                                 (let ([itm (car lst)])
    48                                         (cond
    49                                                 [(pair? itm)
    50                                                         (if (eq? 'require-at-runtime (car itm))
    51                                                                 (set! rqr@run (append (cdr itm) rqr@run))
    52                                                                 (set! opt-args (cons itm opt-args)) )]
    53                                                 [(symbol? itm)
    54                                                         (if (char=? #\+ (string-ref (symbol->string itm) 0))
    55                                                                 (switch itm
    56                                                                         ['+easyffi
    57                                                                                 (when needs-easyffi?
    58                                                                                         (set! cmp-args (append '(easyffi -extend) cmp-args)) )]
    59                                                                         ['+dollar
    60                                                                                 (when needs-dollar?
    61                                                                                         (set! cmp-args (append '(dollar -extend) cmp-args)) )]
    62                                                                         #;[else
    63                                                                                 (set! cmp-args (append `(,(symbol-drop-first itm) -extend) cmp-args))] )
    64                                                                 (set! cmp-args (cons itm cmp-args)) )]
    65                                                 [(atom? itm)
    66                                                         (set! cmp-args (cons itm cmp-args))]
    67                                                 [else
    68                                                         (set! opt-args (cons itm opt-args))])
    69                                         (loop (cdr lst)) )) ) ) )
     43  (let ([cmp-args '()] [rqr@run '()] [opt-args '()])
     44    (let loop ([lst opt])
     45      (if (null? lst)
     46        (values (reverse cmp-args) rqr@run opt-args)
     47        (let ([itm (car lst)])
     48          (cond
     49            [(pair? itm)
     50              (if (eq? 'require-at-runtime (car itm))
     51                (set! rqr@run (append (cdr itm) rqr@run))
     52                (set! opt-args (cons itm opt-args)) )]
     53            [(symbol? itm)
     54              (if (char=? #\+ (string-ref (symbol->string itm) 0))
     55                (switch itm
     56                  ['+easyffi
     57                    (when needs-easyffi?
     58                      (set! cmp-args (append '(easyffi -extend) cmp-args)) )]
     59                  ['+dollar
     60                    (when needs-dollar?
     61                      (set! cmp-args (append '(dollar -extend) cmp-args)) )]
     62                  #;[else
     63                    (set! cmp-args (append `(,(symbol-drop-first itm) -extend) cmp-args))] )
     64                (set! cmp-args (cons itm cmp-args)) )]
     65            [(atom? itm)
     66              (set! cmp-args (cons itm cmp-args))]
     67            [else
     68              (set! opt-args (cons itm opt-args))])
     69          (loop (cdr lst)) )) ) ) )
    7070
    7171;;;
    7272
    7373(define-macro (copy-to-repository FN)
    74         `(copy-file
    75                 (->string ,FN)
    76                 (make-repository-pathname (->string ,FN))) )
     74  `(copy-file
     75    (->string ,FN)
     76    (make-repository-pathname (->string ,FN))) )
    7777
    7878(define-macro (compile-dynld DYN . OPT)
    79         `(compile
    80                 -s
    81                 -O2 -d1
    82                 ,(make-source-filename DYN)
    83                 -o ,(make-dynld-filename DYN)
    84                 ,@(if has-exports? `(-check-imports -emit-exports ,(make-exports-filename DYN)) '())
    85                 ,@OPT) )
     79  `(compile
     80    -s
     81    -O2 -d1
     82    ,(make-source-filename DYN)
     83    -o ,(make-dynld-filename DYN)
     84    ,@(if has-exports? `(-check-imports -emit-exports ,(make-exports-filename DYN)) '())
     85    ,@OPT) )
    8686
    8787(define-macro (install-dynld DYN VER . OPT)
    88         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    89                 `(begin
    90                         (compile-dynld ,DYN ,@CMP-ARGS)
    91                         (install-extension ',(->symbol DYN)
    92                                 '(
    93                                         ,(make-dynld-filename DYN)
    94                                         ,@(if has-exports? `(,(make-exports-filename DYN)) '()) )
    95                                 '(
    96                                         ,@OPT-ARGS
    97                                         ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
    98                                         (version ,VER)
    99                                         ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     88  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     89    `(begin
     90      (compile-dynld ,DYN ,@CMP-ARGS)
     91      (install-extension ',(->symbol DYN)
     92        '(
     93          ,(make-dynld-filename DYN) )
     94        '(
     95          ,@OPT-ARGS
     96          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
     97          (version ,VER)
     98          ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
    10099
    101100(define-macro (install-dynld+docu DYN VER . OPT)
    102         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    103                 `(begin
    104                         (compile-dynld ,DYN ,@CMP-ARGS)
    105                         (install-extension ',(->symbol DYN)
    106                                 '(
    107                                         ,(make-dynld-filename DYN)
    108                                         ,(make-docu-filename DYN)
    109                                         ,@(if has-exports? `(,(make-exports-filename DYN)) '()) )
    110                                 '(
    111                                         ,@OPT-ARGS
    112                                         ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
    113                                         (documentation ,(make-docu-filename DYN))
    114                                         (version ,VER)
    115                                         ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     101  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     102    `(begin
     103      (compile-dynld ,DYN ,@CMP-ARGS)
     104      (install-extension ',(->symbol DYN)
     105        '(
     106          ,(make-dynld-filename DYN)
     107          ,(make-docu-filename DYN) )
     108        '(
     109          ,@OPT-ARGS
     110          ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
     111          (documentation ,(make-docu-filename DYN))
     112          (version ,VER)
     113          ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
    116114
    117115(define-macro (install-syntax SYN VER . OPT)
    118         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    119                 `(install-extension ',(->symbol SYN)
    120                         '(
    121                                 ,(make-source-filename SYN) )
    122                         '(
    123                                 ,@OPT-ARGS
    124                                 ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
    125                                 (version ,VER)
    126                                 (syntax) ) ) ) )
     116  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     117    `(install-extension ',(->symbol SYN)
     118      '(
     119        ,(make-source-filename SYN) )
     120      '(
     121        ,@OPT-ARGS
     122        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
     123        (version ,VER)
     124        (syntax) ) ) ) )
    127125
    128126(define-macro (install-syntax+docu SYN VER . OPT)
    129         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    130                 `(install-extension ',(->symbol SYN)
    131                         '(
    132                                 ,(make-source-filename SYN)
    133                                 ,(make-docu-filename SYN) )
    134                         '(
    135                                 ,@OPT-ARGS
    136                                 ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
    137                                 (version ,VER)
    138                                 (documentation ,(make-docu-filename SYN))
    139                                 (syntax) ) ) ) )
     127  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     128    `(install-extension ',(->symbol SYN)
     129      '(
     130        ,(make-source-filename SYN)
     131        ,(make-docu-filename SYN) )
     132      '(
     133        ,@OPT-ARGS
     134        ,@(if (null? RQR@RUN) '() `((require-at-runtime ,@RQR@RUN)))
     135        (version ,VER)
     136        (documentation ,(make-docu-filename SYN))
     137        (syntax) ) ) ) )
    140138
    141139(define-macro (install-dynld+syntax SYN DYN VER . OPT)
    142         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    143                 `(begin
    144                         (compile-dynld ,DYN ,@CMP-ARGS)
    145                         (install-extension ',(->symbol SYN)
    146                                 '(
    147                                         ,(make-source-filename SYN)
    148                                         ,(make-dynld-filename DYN)
    149                                         ,@(if has-exports? `(,(make-exports-filename DYN)) '()) )
    150                                 '(
    151                                         ,@OPT-ARGS
    152                                         (syntax)
    153                                         (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
    154                                         (version ,VER)
    155                                         ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     140  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     141    `(begin
     142      (compile-dynld ,DYN ,@CMP-ARGS)
     143      (install-extension ',(->symbol SYN)
     144        '(
     145          ,(make-source-filename SYN)
     146          ,(make-dynld-filename DYN) )
     147        '(
     148          ,@OPT-ARGS
     149          (syntax)
     150          (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
     151          (version ,VER)
     152          ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
    156153
    157154(define-macro (install-dynld+syntax+docu SYN DYN VER . OPT)
    158         (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
    159                 `(begin
    160                         (compile-dynld ,DYN ,@CMP-ARGS)
    161                         (install-extension ',(->symbol SYN)
    162                                 '(
    163                                         ,(make-docu-filename SYN)
    164                                         ,(make-source-filename SYN)
    165                                         ,(make-dynld-filename DYN)
    166                                         ,@(if has-exports? `(,(make-exports-filename DYN)) '()) )
    167                                 '(
    168                                         ,@OPT-ARGS
    169                                         (documentation ,(make-docu-filename SYN))
    170                                         (syntax)
    171                                         (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
    172                                         (version ,VER)
    173                                         ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
     155  (let-values (([CMP-ARGS RQR@RUN OPT-ARGS] (parse-optionals OPT)))
     156    `(begin
     157      (compile-dynld ,DYN ,@CMP-ARGS)
     158      (install-extension ',(->symbol SYN)
     159        '(
     160          ,(make-docu-filename SYN)
     161          ,(make-source-filename SYN)
     162          ,(make-dynld-filename DYN) )
     163        '(
     164          ,@OPT-ARGS
     165          (documentation ,(make-docu-filename SYN))
     166          (syntax)
     167          (require-at-runtime ,(->symbol DYN) ,@RQR@RUN)
     168          (version ,VER)
     169          ,@(if has-exports? `((exports ,(make-exports-filename DYN))) '()) ) ) ) ) )
Note: See TracChangeset for help on using the changeset viewer.