Changeset 10796 in project


Ignore:
Timestamp:
05/13/08 02:06:05 (12 years ago)
Author:
Ivan Raikov
Message:

Factored out unit ports from extras and utils.

Location:
chicken/trunk
Files:
1 added
17 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/NEWS

    r10662 r10796  
     13.2.1
     2
     3- unit utils and extras: moved port extensions to unit ports
     4- new unit ports
     5
    163.2.0
    27
  • chicken/trunk/c-platform.scm

    r10524 r10796  
    100100       ##sys#profile-entry ##sys#profile-exit) ) ) )
    101101
    102 (define units-used-by-default '(library eval data-structures extras srfi-69))
     102(define units-used-by-default '(library eval data-structures ports extras srfi-69))
    103103(define words-per-flonum 4)
    104104(define parameter-limit 1024)
  • chicken/trunk/csc.scm

    r10526 r10796  
    2828(declare
    2929  (block)
    30   (uses data-structures srfi-1 srfi-13 utils extras ))
     30  (uses data-structures ports srfi-1 srfi-13 utils extras ))
    3131
    3232#>
  • chicken/trunk/debian/rules

    r10737 r10796  
    7777        dh_installinfo chicken.info*
    7878        dh_installchangelogs ChangeLog.*
     79        dh_install --autodest
    7980        dh_link
    8081ifeq "$(findstring nostrip,$(DEB_BUILD_OPTIONS))" ""
  • chicken/trunk/distribution/manifest

    r10634 r10796  
    5757data-structures.c
    5858data-structures.exports
     59ports.c
     60ports.exports
    5961extras.c
    6062extras.exports
     
    9294uextras.c
    9395udata-structures.c
     96uports.c
    9497ulibrary.c
    9598ulolevel.c
     
    135138extras.scm
    136139data-structures.scm
     140ports.scm
    137141chicken-bug.1
    138142chicken-bug.scm
     
    166170html/supported-language.html
    167171html/unit-data-structures.html
     172html/unit-ports.html
    168173html/unit-eval.html
    169174html/unit-extras.html
  • chicken/trunk/eval.scm

    r10525 r10796  
    106106(define ##sys#core-library-modules
    107107  '(extras lolevel utils tcp regex regex-extras posix match
    108     data-structures srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69))
     108    data-structures ports srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69))
    109109
    110110(define ##sys#explicit-library-modules '())
  • chicken/trunk/extras.scm

    r10509 r10796  
    319319
    320320
    321 ;;; Redirect standard ports:
    322 
    323 (define (with-input-from-port port thunk)
    324   (##sys#check-port port 'with-input-from-port)
    325   (fluid-let ([##sys#standard-input port])
    326     (thunk) ) )
    327 
    328 (define (with-output-to-port port thunk)
    329   (##sys#check-port port 'with-output-from-port)
    330   (fluid-let ([##sys#standard-output port])
    331     (thunk) ) )
    332 
    333 (define (with-error-output-to-port port thunk)
    334   (##sys#check-port port 'with-error-output-from-port)
    335   (fluid-let ([##sys#standard-error port])
    336     (thunk) ) )
    337 
    338 
    339 ;;; Extended string-port operations:
    340  
    341 (define call-with-input-string
    342   (let ([open-input-string open-input-string])
    343     (lambda (str proc)
    344       (let ((in (open-input-string str)))
    345         (proc in) ) ) ) )
    346 
    347 (define call-with-output-string
    348   (let ((open-output-string open-output-string)
    349         (get-output-string get-output-string) )
    350     (lambda (proc)
    351       (let ((out (open-output-string)))
    352         (proc out)
    353         (get-output-string out) ) ) ) )
    354 
    355 (define with-input-from-string
    356   (let ((open-input-string open-input-string))
    357     (lambda (str thunk)
    358       (fluid-let ([##sys#standard-input (open-input-string str)])
    359         (thunk) ) ) ) )
    360 
    361 (define with-output-to-string
    362   (let ([open-output-string open-output-string]
    363         [get-output-string get-output-string] )
    364     (lambda (thunk)
    365       (fluid-let ([##sys#standard-output (open-output-string)])
    366         (thunk)
    367         (get-output-string ##sys#standard-output) ) ) ) )
    368 
    369 
    370 ;;; Custom ports:
    371 ;
    372 ; - Port-slots:
    373 ;
    374 ;   10: last
    375 
    376 (define make-input-port
    377   (lambda (read ready? close #!optional peek read-string read-line)
    378     (let* ((class
    379             (vector
    380              (lambda (p)                ; read-char
    381                (let ([last (##sys#slot p 10)])
    382                  (cond [peek (read)]
    383                        [last
    384                         (##sys#setislot p 10 #f)
    385                         last]
    386                        [else (read)] ) ) )
    387              (lambda (p)                ; peek-char
    388                (let ([last (##sys#slot p 10)])
    389                  (cond [peek (peek)]
    390                        [last last]
    391                        [else
    392                         (let ([last (read)])
    393                           (##sys#setslot p 10 last)
    394                           last) ] ) ) )
    395              #f                         ; write-char
    396              #f                         ; write-string
    397              (lambda (p)                ; close
    398                (close)
    399                (##sys#setislot p 8 #t) )
    400              #f                         ; flush-output
    401              (lambda (p)                ; char-ready?
    402                (ready?) )
    403              read-string                ; read-string!
    404              read-line) )               ; read-line
    405            (data (vector #f))
    406            (port (##sys#make-port #t class "(custom)" 'custom)) )
    407       (##sys#setslot port 9 data)
    408       port) ) )
    409 
    410 (define make-output-port
    411   (let ([string string])
    412     (lambda (write close #!optional flush)
    413       (let* ((class
    414               (vector
    415                #f                       ; read-char
    416                #f                       ; peek-char
    417                (lambda (p c)            ; write-char
    418                  (write (string c)) )
    419                (lambda (p s)            ; write-string
    420                  (write s) )
    421                (lambda (p)              ; close
    422                  (close)
    423                  (##sys#setislot p 8 #t) )
    424                (lambda (p)              ; flush-output
    425                  (when flush (flush)) )
    426                #f                       ; char-ready?
    427                #f                       ; read-string!
    428                #f) )                    ; read-line
    429              (data (vector #f))
    430              (port (##sys#make-port #f class "(custom)" 'custom)) )
    431         (##sys#setslot port 9 data)
    432         port) ) ) )
    433321
    434322
  • chicken/trunk/manual/Supported language

    r10513 r10796  
    1414* [[Unit eval]] evaluation and macro-handling
    1515* [[Unit data-structures]] data structures
     16* [[Unit ports]] I/O ports
    1617* [[Unit extras]] useful utility definitions
    1718* [[Unit srfi-1]] list library
  • chicken/trunk/manual/Unit data-structures

    r10514 r10796  
    576576Previous: [[Unit eval]]
    577577
    578 Next: [[Unit extras]]
     578Next: [[Unit ports]]
  • chicken/trunk/manual/Unit extras

    r10513 r10796  
    77This unit is used by default, unless the program
    88is compiled with the {{-explicit-use}} option.
    9 
    10 
    11 === String-port extensions
    12 
    13 
    14 ==== call-with-input-string
    15 
    16  [procedure] (call-with-input-string STRING PROC)
    17 
    18 Calls the procedure {{PROC}} with a single argument that is a
    19 string-input-port with the contents of {{STRING}}.
    20 
    21 
    22 ==== call-with-output-string
    23 
    24  [procedure] (call-with-output-string PROC)
    25 
    26 Calls the procedure {{PROC}} with a single argument that is a
    27 string-output-port.  Returns the accumulated output-string.
    28 
    29 
    30 ==== with-input-from-string
    31 
    32  [procedure] (with-input-from-string STRING THUNK)
    33 
    34 Call procedure {{THUNK}} with the current input-port temporarily
    35 bound to an input-string-port with the contents of {{STRING}}.
    36 
    37 
    38 ==== with-output-to-string
    39 
    40  [procedure] (with-output-to-string THUNK)
    41 
    42 Call procedure {{THUNK}} with the current output-port temporarily
    43 bound to a string-output-port and return the accumulated output string.
    44 
    459
    4610
     
    13195
    13296
    133 
    13497=== Input/Output extensions
    135 
    136 
    137 ==== make-input-port
    138 
    139  [procedure] (make-input-port READ READY? CLOSE [PEEK])
    140 
    141 Returns a custom input port. Common operations on this
    142 port are handled by the given parameters, which should be
    143 procedures of no arguments. {{READ}} is called when the
    144 next character is to be read and should return a character or
    145 {{#!eof}}. {{READY?}} is called
    146 when {{char-ready?}} is called on this port and should return
    147 {{#t}} or {{#f}}.  {{CLOSE}} is called when the port is
    148 closed. {{PEEK}} is called when {{peek-char}} is called on this
    149 port and should return a character or {{#!eof}}.
    150 if the argument {{PEEK}} is not given, then {{READ}} is used
    151 instead and the created port object handles peeking automatically (by
    152 calling {{READ}} and buffering the character).
    153 
    154 
    155 ==== make-output-port
    156 
    157  [procedure] (make-output-port WRITE CLOSE [FLUSH])
    158 
    159 Returns a custom output port. Common operations on this port are handled
    160 by the given parameters, which should be procedures.  {{WRITE}} is
    161 called when output is sent to the port and receives a single argument,
    162 a string.  {{CLOSE}} is called when the port is closed and should
    163 be a procedure of no arguments. {{FLUSH}} (if provided) is called
    164 for flushing the output port.
    165 
    16698
    16799==== pretty-print
     
    251183
    252184
    253 ==== with-error-output-to-port
    254 
    255  [procedure] (with-error-output-to-port PORT THUNK)
    256 
    257 Call procedure {{THUNK}} with the current error output-port
    258 temporarily bound to {{PORT}}.
    259 
    260 
    261 ==== with-input-from-port
    262 
    263  [procedure] (with-input-from-port PORT THUNK)
    264 
    265 Call procedure {{THUNK}} with the current input-port temporarily
    266 bound to {{PORT}}.
    267 
    268 
    269 ==== with-output-to-port
    270 
    271  [procedure] (with-output-to-port PORT THUNK)
    272 
    273 Call procedure {{THUNK}} with the current output-port temporarily
    274 bound to {{PORT}}.
    275 
    276 
    277 
    278 Previous: [[Unit data-structures]]
     185Previous: [[Unit ports]]
    279186
    280187Next: [[Unit srfi-1]]
  • chicken/trunk/manual/Unit utils

    r10513 r10796  
    190190</enscript>
    191191
    192 ==== port-for-each
    193 
    194  [procedure] (port-for-each FN THUNK)
    195 
    196 Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}}
    197 until it returns {{#!eof}}, discarding the results.
    198 
    199 ==== port-map
    200 
    201  [procedure] (port-map FN THUNK)
    202 
    203 Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}}
    204 until it returns {{#!eof}}, returning a list of the collected results.
    205 
    206 ==== port-fold
    207 
    208  [procedure] (port-map FN ACC THUNK)
    209 
    210 Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}},
    211 passing the {{ACC}} value as the second argument. The {{FN}} result becomes the new
    212 {{ACC}} value. When {{THUNK}} returns {{#!eof}}, the last {{FN}} result is returned.
    213 
    214192=== Executing shell commands with formatstring and error checking
    215193
     
    234212port that is the current value of {{(current-input-port)}}.
    235213
    236 
    237 === Funky ports
    238 
    239 ==== make-broadcast-port
    240 
    241  [procedure] (make-broadcast-port PORT ...)
    242 
    243 Returns a custom output port that emits everything written into it to
    244 the ports given as {{PORT ...}}. Closing the broadcast port does not close
    245 any of the argument ports.
    246 
    247 ==== make-concatenated-port
    248 
    249  [procedure] (make-concatenated-port PORT1 PORT2 ...)
    250 
    251 Returns a custom input port that reads its input from {{PORT1}}, until it
    252 is empty, then from {{PORT2}} and so on. Closing the concatenated port
    253 does not close any of the argument ports.
    254 
    255 
    256 ===  Miscellaneous handy things
    257 
    258 ==== shift! DEPRECATED
    259 
    260  [procedure] (shift! LIST [DEFAULT])
    261 
    262 Returns the car of {{LIST}} (or {{DEFAULT}} if {{LIST}} is empty) and replaces
    263 the car of {{LIST}} with it's cadr and the cdr with the cddr. If {{DEFAULT}} is not given, and
    264 the list is empty, {{#f}} is returned. An example might be clearer, here:
    265 
    266 <enscript highlight=scheme>
    267 (define lst '(1 2 3))
    268 (shift! lst)             ==> 1, lst is now (2 3)
    269 </enscript>
    270 
    271 The list must contain at least 2 elements.
    272 
    273 ==== unshift! DEPRECATED
    274 
    275  [procedure] (unshift! X PAIR)
    276 
    277 Sets the car of {{PAIR}} to {{X}} and the cdr to its cddr. Returns {{PAIR}}:
    278 
    279 <enscript highlight=scheme>
    280 (define lst '(2))
    281 (unshift! 99 lst)      ; lst is now (99 2)
    282 </enscript>
    283 
    284 
    285214Previous: [[Unit posix]]
    286215
  • chicken/trunk/rules.make

    r10681 r10796  
    2929
    3030LIBCHICKEN_OBJECTS_1 = \
    31        library eval data-structures extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     31       library eval data-structures ports extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
    3232       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
    3333       profiler stub match runtime
     
    3636
    3737LIBUCHICKEN_OBJECTS_1 = \
    38        ulibrary ueval udata-structures uextras ulolevel uutils utcp usrfi-1 usrfi-4 \
     38       ulibrary ueval udata-structures uports uextras ulolevel uutils utcp usrfi-1 usrfi-4 \
    3939       usrfi-13 usrfi-14 usrfi-18 usrfi-69 u$(POSIXFILE) uregex scheduler \
    4040       profiler stub match uruntime
     
    4343
    4444LIBCHICKENGUI_OBJECTS_1 = \
    45        library eval data-structures extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
     45       library eval data-structures ports extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
    4646       srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
    4747       profiler stub match gui-runtime
     
    9898          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
    9999          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     100ports$(O): ports.c chicken.h $(CHICKEN_CONFIG_H)
     101        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     102          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     103          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    100104extras$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
    101105        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    180184          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    181185udata-structures$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
     186        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     187          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     188          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     189uports$(O): uports.c chicken.h $(CHICKEN_CONFIG_H)
    182190        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    183191          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
     
    257265          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
    258266          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     267ports-static$(O): ports.c chicken.h $(CHICKEN_CONFIG_H)
     268        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     269          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     270          $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    259271extras-static$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
    260272        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     
    339351          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
    340352udata-structures-static$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
     353        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
     354          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     355          $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
     356uports-static$(O): uports.c chicken.h $(CHICKEN_CONFIG_H)
    341357        $(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) \
    342358          $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
     
    895911data-structures.c: data-structures.scm private-namespace.scm
    896912        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
     913ports.c: ports.scm private-namespace.scm
     914        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
    897915extras.c: extras.scm private-namespace.scm
    898916        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend private-namespace.scm
     
    935953        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
    936954udata-structures.c: data-structures.scm private-namespace.scm
     955        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend private-namespace.scm
     956uports.c: ports.scm private-namespace.scm
    937957        $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend private-namespace.scm
    938958uextras.c: extras.scm private-namespace.scm
     
    9931013.PHONY: distfiles
    9941014
    995 distfiles: buildsvnrevision library.c eval.c data-structures.c extras.c lolevel.c utils.c \
     1015distfiles: buildsvnrevision library.c eval.c data-structures.c ports.c extras.c lolevel.c utils.c \
    9961016        tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
    9971017        posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c match.c \
    998         ulibrary.c ueval.c udata-structures.c uextras.c ulolevel.c \
     1018        ulibrary.c ueval.c udata-structures.c uports.c uextras.c ulolevel.c \
    9991019        uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    10001020        usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
     
    10281048
    10291049spotless: distclean
    1030         -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c data-structures.c extras.c lolevel.c utils.c \
    1031           tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
     1050        -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c data-structures.c ports.c \
     1051          extras.c lolevel.c utils.c tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
    10321052          posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c match.c \
    1033           ulibrary.c ueval.c udata-structures.c uextras.c ulolevel.c \
     1053          ulibrary.c ueval.c udata-structures.c uports.c uextras.c ulolevel.c \
    10341054          uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
    10351055          usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-setup.c chicken-bug.c \
     
    10811101
    10821102bootstrap.tar.gz: distfiles
    1083         tar cfz bootstrap.tar.gz library.c eval.c data-structures.c extras.c lolevel.c utils.c tcp.c \
     1103        tar cfz bootstrap.tar.gz library.c eval.c data-structures.c uports.c extras.c lolevel.c utils.c tcp.c \
    10841104          srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
    10851105          scheduler.c profiler.c stub.c match.c $(COMPILER_OBJECTS_1:=.c)
  • chicken/trunk/scripts/makehtml.scm

    r10512 r10796  
    100100    "Unit eval"
    101101    "Unit data-structures"
     102    "Unit ports"
    102103    "Unit extras"
    103104    "Unit srfi-1"
  • chicken/trunk/scripts/maketexi.scm

    r10640 r10796  
    3737                             "Unit eval"
    3838                             "Unit data-structures"
     39                             "Unit ports"
    3940                             "Unit extras"
    4041                             "Unit srfi-1"
  • chicken/trunk/stub.scm

    r10526 r10796  
    2828(declare
    2929  (unit default_stub)
    30   (uses library eval data-structures extras)
     30  (uses library eval data-structures ports extras)
    3131  (not safe) )
    3232
  • chicken/trunk/tcp.scm

    r10526 r10796  
    2828(declare
    2929  (unit tcp)
    30   (uses data-structures extras scheduler)
     30  (uses data-structures ports extras scheduler)
    3131  (usual-integrations)
    3232  (fixnum-arithmetic)
  • chicken/trunk/utils.scm

    r10526 r10796  
    515515        (with-input-from-file file (cut read-string #f)) ) ) )
    516516
    517 
    518 ;;; Handy little things:
    519 
    520 (define (shift! lst #!optional default) ;; DEPRECATED
    521   (if (null? lst)
    522       default
    523       (begin
    524         (##sys#check-pair lst 'shift!)
    525         (let ([x (##sys#slot lst 0)]
    526               [d (##sys#slot lst 1)] )
    527           (##sys#check-pair d 'shift!)
    528           (##sys#setslot lst 1 (##sys#slot d 1))
    529           (##sys#setslot lst 0 (##sys#slot d 0))
    530           x) ) ) )
    531 
    532 (define (unshift! x lst) ;; DEPRECATED
    533   (##sys#check-pair lst 'unshift!)
    534   (##sys#setslot lst 1 (cons (##sys#slot lst 0) (##sys#slot lst 1)))
    535   (##sys#setslot lst 0 x)
    536   lst)
    537 
    538 
    539 ;;;; Port-mapping (found in Gauche):
    540 
    541 (define (port-for-each fn thunk)
    542   (let loop ()
    543     (let ((x (thunk)))
    544       (unless (eq? x #!eof)
    545         (fn x)
    546         (loop) ) ) ) )
    547 
    548 (define port-map
    549   (let ((reverse reverse))
    550     (lambda (fn thunk)
    551       (let loop ((xs '()))
    552         (let ((x (thunk)))
    553           (if (eq? x #!eof)
    554               (reverse xs)
    555               (loop (cons (fn x) xs))))))))
    556 
    557 (define (port-fold fn acc thunk)
    558   (let loop ([acc acc])
    559     (let ([x (thunk)])
    560       (if (eq? x #!eof)
    561         acc
    562         (loop (fn x acc))) ) ) )
    563 
    564 ;;;; funky-ports
    565 
    566 (define (make-broadcast-port . ports)
    567   (make-output-port
    568    (lambda (s) (for-each (cut write-string s #f <>) ports))
    569    noop
    570    (lambda () (for-each flush-output ports)) ) )
    571 
    572 (define (make-concatenated-port p1 . ports)
    573   (let ((ports (cons p1 ports)))
    574     (make-input-port
    575      (lambda ()
    576        (let loop ()
    577          (if (null? ports)
    578              #!eof
    579              (let ((c (read-char (car ports))))
    580                (cond ((eof-object? c)
    581                       (set! ports (cdr ports))
    582                       (loop) )
    583                      (else c) ) ) ) ) )
    584      (lambda ()
    585        (and (not (null? ports))
    586             (char-ready? (car ports))))
    587      noop
    588      (lambda ()
    589        (let loop ()
    590          (if (null? ports)
    591              #!eof
    592              (let ((c (peek-char (car ports))))
    593                (cond ((eof-object? c)
    594                       (set! ports (cdr ports))
    595                       (loop) )
    596                      (else c))))))
    597      (lambda (p n dest start)
    598        (let loop ((n n) (c 0))
    599          (cond ((null? ports) c)
    600                ((fx<= n 0) c)
    601                (else
    602                 (let ((m (read-string! n dest (car ports) (fx+ start c))))
    603                   (when (fx< m n)
    604                     (set! ports (cdr ports)) )
    605                   (loop (fx- n m) (fx+ c m))))))))))
Note: See TracChangeset for help on using the changeset viewer.