[Wisp-cvs] wisp/src/builtin filing.wisp,1.109,1.110 records.wisp,1.8,1.9 stdenv.wisp,1.370,1.371 tostring.wisp,1.81,1.82

[<di...@us...>]

Update of /cvsroot/wisp/wisp/src/builtin
In directory usw-pr-cvs1:/tmp/cvs-serv2015/src/builtin

Modified Files:
	filing.wisp records.wisp stdenv.wisp tostring.wisp 
Log Message:
Introduced the new, more polymorphic port mechanism.

Index: filing.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/filing.wisp,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -d -r1.109 -r1.110
--- filing.wisp	18 Sep 2002 21:12:38 -0000	1.109
+++ filing.wisp	18 Sep 2002 21:16:49 -0000	1.110
@@ -14,35 +14,21 @@
 (define (raise-unwritable-port port . rest)
   (raise 'unwritable-port port))
 
-(define (raise-unseekable-port port . rest)
-  (raise 'unseekable-port port))
-
-;; Some ports communicate with data strings and can seek along them.
-;; Others communicate with serial sinks and sources that are unseekable.
-;; Since input buffering is unavoidable, you better assume that reading
-;; a file sets the write pointer to an undefined value and vice versa,
-;; so you need to do an explicit seek.
-;; Unfortunately, Wisp can't check the correct order since there are
-;; some files (like TCP sessions or character devices) which don't need
-;; seeking at all.
-
-(define-class <port>
+(define-class <old-port>
   (read-only
     eof?)
   (hidden
     buffer start stop
     raw-read-string raw-write-string ; they take: port string start count
-    raw-seek ; takes: port whence delta
     close-hook ; takes: port read? write?
     raw-ready? ; takes: port
     ensure-in-buffer) ; takes: count [block?]
-  (friend (init-port port reader writer seeker clhook ready?)
+  (friend (init-port port reader writer clhook ready?)
     (set! start 0)
     (set! stop 0)
     (set! eof? #f)
     (set! raw-read-string (or reader raise-unreadable-port))
     (set! raw-write-string (or writer raise-unwritable-port))
-    (set! raw-seek (or seeker raise-unseekable-port))
     (set! close-hook clhook)
     (set! raw-ready? ready?)
     (set! buffer (make-string 16))
@@ -121,7 +107,7 @@
       (if (or (number? e) (eq? e #t))
         buffer[start]
         e)))
-  (friend (port-read-string port amount block?)
+  (friend (port-read-string port amount (block? #t))
     (my s (port-peek-string port amount block?)
       (if (string? s)
         (incr! start (length s)))
@@ -147,27 +133,22 @@
     (set! start 0)
     (set! stop 0)
     (set! eof? #f))
-  (friend (seek port whence delta)
-    (if (eq? whence 'relative)     ; if we've recently read
-      (decr! delta (- stop start))) ; seek relative to the read buffer's start
-    (drop-buffer port)
-    (raw-seek port whence delta))
   (friend (port-write-string port s)
     (drop-buffer port)
     (raw-write-string port s 0 (length s)))
-  (friend (close-input-port port)
+  (friend (%close-input-port port)
     (set! raw-read-string raise-unreadable-port)
     (hold
       (if close-hook
         (close-hook port #t (eq? raw-write-string raise-unwritable-port))
         (begin))
       (set! buffer '()))) ; deallocate buffer storage
-  (friend (close-output-port port)
+  (friend (%close-output-port port)
     (set! raw-write-string raise-unwritable-port)
     (if close-hook
       (close-hook port (eq? raw-read-string raise-unreadable-port) #t)
       (begin)))
-  (friend (close-port port)
+  (friend (%close-port port)
     (set! raw-read-string raise-unreadable-port)
     (set! raw-write-string raise-unwritable-port)
     (if close-hook
@@ -182,27 +163,20 @@
   (friend (output-port? port)
     (not (eq? raw-write-string raise-unwritable-port))))
 
-(define-class (<file> <port>)
+(define-class (<old-file> <old-port>)
   (read-only
     fd)
   (friend (init-input-file port fildes (clhook file-close-hook))
-    (init-port port raw-input-file-reader #f raw-file-seeker clhook file-ready?)
+    (init-port port raw-input-file-reader #f clhook file-ready?)
     (set! fd fildes))
   (friend (init-output-file port readable? fildes (clhook file-close-hook))
     (init-port port (and readable? raw-input-file-reader)
-               raw-output-file-writer raw-file-seeker clhook file-ready?)
+               raw-output-file-writer clhook file-ready?)
     (set! fd fildes))
   (friend (raw-input-file-reader port string start-pos count)
     (sys:read fd string start-pos count))
   (friend (raw-output-file-writer port string start-pos count)
     (sys:write fd string start-pos count))
-  (friend (raw-file-seeker port whence delta)
-    (sys:lseek fd delta (system-constant 'fcntl 'seek
-                          (case whence
-                            ((absolute) 'SEEK_SET)
-                            ((relative) 'SEEK_CUR)
-                            ((end)      'SEEK_END)
-                            (else (raise 'invalid-whence whence))))))
   (friend (file-close-hook port read? write?)
     (if (and read? write?)
       (begin
@@ -212,13 +186,54 @@
     (my fdset (make-fdset)
       (set! (fdset-ref fdset fd) #t)
       (not (zero? (sys:select (+ fd 1) fdset #f #f 0 0)))))
-  (friend (file-descriptor port)
+  (friend (%file-descriptor port)
     fd))
 
-(define (read-char (port (current-input-port)))
-  (if (instance? port)
-    (%read-char port)
-    (((asm NN_pr_record_type_read_char_slot) (type-of port)) port)))
+(my (%<file> %make-file %file-fd %file-mode)
+  (make-record-type 2
+   'read-string (lambda (%<file> %make-file %file-fd %file-mode)
+                  (lambda (file amount)
+                    (my fd (%file-fd file)
+                      (if (or (not fd)
+                              (not (memq (%file-mode file)
+                                         '(read #t))))
+                        (raise 'input-port? file))
+                      (my s (make-c8string amount)
+                        (my res (sys:read fd s 0 amount)
+                          (cond
+                            ((= res amount) s)
+                            ((zero? amount) (begin)) ; FIXME: not entirely correct
+                            (else (substring s 0 res))))))))
+   'write-string (lambda (%<file> %make-file %file-fd %file-mode)
+                   (lambda (file s)
+                     (my fd (%file-fd file)
+                       (if (or (not fd)
+                               (not (memq (%file-mode file)
+                                          '(write #t))))
+                         (raise 'output-port? file))
+                       ; FIXME: what if writing doesn't entirely succeed?
+                       (sys:write fd s 0 (length s)))))
+   'close-port (lambda (%<file> %make-file %file-fd %file-mode)
+                 (lambda (file direction)
+                   (my fd (%file-fd file)
+                     (if fd
+                       (cond
+                         ((or (eq? direction #t)
+                              (eq? direction (%file-mode file)))
+                           (sys:close fd)
+                           (set! (%file-fd file) #f)
+                           (set! (%file-mode file) #f))
+                         ((eq? direction 'read)
+                           (set! (%file-mode file) 'write))
+                         ((eq? direction 'write)
+                           (set! (%file-mode file) 'read))))
+                     (begin)))))
+  (define <file> %<file>)
+  (define make-file %make-file)
+  (define (file-descriptor file)
+    (if (instance? file)
+      (%file-descriptor file)
+      (%file-fd file))))
 
 (define (construct-filename dir base)
   (cond
@@ -229,7 +244,7 @@
     (else                 (string-append dir #\/ base))))
 
 (define (%fd->port fd)
-  (my port (make-instance <file>)
+  (my port (make-instance <old-file>)
     (init-input-file port fd)
     port))
 
@@ -339,21 +354,21 @@
             (else
               (raise 'unknown-open-output-file-flag f)))))
       (cdr! flags))
-    (my port (make-instance <file>)
-      (init-output-file port readable?
-        (sys:open name (logical-or (system-constant 'open
-                                                    (if readable?
-                                                      'O_RDWR
-                                                      'O_WRONLY))
-                        bitfield) mode))
-      port)))
+    (my fd (sys:open name (logical-or (system-constant 'open
+                                                       (if readable?
+                                                         'O_RDWR
+                                                         'O_WRONLY))
+                                      bitfield) mode)
+      (if readable?
+        (my port (make-instance <old-file>)
+          (init-output-file port readable? fd)
+          port)
+        (make-file fd 'write)))))
 
-(let ((*stdin* (make-instance <file>))
-      (*stdout* (make-instance <file>))
-      (*stderr* (make-instance <file>)))
+(let ((*stdin* (make-instance <old-file>))
+      (*stdout* (make-file 1 'write))
+      (*stderr* (make-file 2 'write)))
   (init-input-file *stdin* 0)
-  (init-output-file *stdout* #f 1)
-  (init-output-file *stderr* #f 2)
 
   (define stdin$ (make-fluid *stdin*))
   (define stdout$ (make-fluid *stdout*))
@@ -374,12 +389,9 @@
 
 ;; General file operations
 
-(define port? (class-discriminator <port>))
-
-(define file? (class-discriminator <file>))
+(define port? (class-discriminator <old-port>))
 
-(define (read-string length (port (current-input-port)) (block? #t))
- (port-read-string port length block?))
+(define file? (class-discriminator <old-file>))
 
 (define (peek-string length (port (current-input-port)) (block? #t))
  (port-peek-string port length block?))
@@ -453,19 +465,126 @@
 (define (read-char (port (current-input-port)))
   (if (instance? port)
     (%read-char port)
-    (((asm NN_pr_record_type_read_char_slot) (type-of port)) port)))
+    (my t (type-of port)
+      (cond
+        ((symbol? t) (raise 'readable? port))
+        (((asm NN_pr_record_type_read_char_slot) t)
+          => (cut <> port))
+        (((asm NN_pr_record_type_read_string_slot) t)
+          => (lambda (sr)
+               (my s (sr port 1)
+                 (if (and (string? s) (= (length s) 1))
+                   s[0]
+                   s))))
+        (else (raise 'readable? port))))))
 
 ; Note that Scheme's |write-char| takes the port argument *last*
 ; whereas the |write-char| hooks take it *first*.
 (define (write-char object (port (current-output-port)))
+  (type char object)
   (if (instance? port)
-    (write-string (string object) port)
-    (((asm NN_pr_record_type_write_char_slot) (type-of port))
-      port object)))
+    (port-write-string port (string object))
+    (my t (type-of port)
+      (cond
+        ((symbol? t) (raise 'writable? port))
+        (((asm NN_pr_record_type_write_char_slot) t)
+          => (cut <> port object))
+        (((asm NN_pr_record_type_write_string_slot) t)
+          => (cut <> port (string object)))
+        (else (raise 'writable? port))))))
+
+;; FIXME: what about terminals?
+(define (read-string amount (port (current-input-port)))
+  (if (instance? port)
+    (port-read-string port amount)
+    (my t (type-of port)
+      (cond
+        ((symbol? t) (raise 'writable? port))
+        (((asm NN_pr_record_type_read_string_slot) t)
+          => (lambda (sr)
+               (my eof? #f
+                 (my data (collect-string
+                            (lambda (emit)
+                              (let (loop (amount amount))
+                                (if (positive? amount)
+                                  (my chunk (sr port amount)
+                                    (cond
+                                      ((eof-object? chunk) (set! eof? #t))
+                                      ((not chunk)) ; no data yet
+                                      ((not (string? chunk))
+                                        (raise 'string? chunk))
+                                      ((string-null? chunk))
+                                      (else (emit chunk)
+                                            (loop (- amount
+                                                     (length chunk))))))))))
+                   (if (and (string-null? data) eof?)
+                     (begin)
+                     data)))))
+        (((asm NN_pr_record_type_read_char_slot) t)
+          => (lambda (cr)
+               (my eof? #f
+                 (my data (collect-string
+                            (lambda (emit)
+                              (let (loop (amount amount))
+                                (if (positive? amount)
+                                  (my ch (cr port amount)
+                                    (cond
+                                      ((eof-object? ch) (set! eof? #t))
+                                      ((not ch)) ; no data yet
+                                      ((not (char? ch))
+                                        (raise 'char? ch))
+                                      (else (emit ch)
+                                            (loop (- amount 1)))))))))
+                   (if (and (string-null? data) eof?)
+                     (begin)
+                     data)))))
+        (else (raise 'readable? port))))))
 
 ; See the comment near |write-char|.
 (define (write-string s (port (current-output-port)))
-  (port-write-string port s))
+  (type string s)
+  (if (instance? port)
+    (port-write-string port s)
+    (my t (type-of port)
+      (cond
+        ((symbol? t) (raise 'writable? port))
+        (((asm NN_pr_record_type_write_string_slot) t)
+          => (cut <> port s))
+        (((asm NN_pr_record_type_write_char_slot) t)
+          => (lambda (cw)
+               (my l (length s)
+                 (my i 0
+                   (while (< i l)
+                     (cw port s[i])
+                     (incr! i))))))
+        (else (raise 'writable? port))))))
+
+(define (close-input-port p)
+  (if (instance? p)
+    (%close-input-port p)
+    (my t (type-of p)
+      (cond
+        ((symbol? t) (raise 'port? p))
+        (((asm NN_pr_record_type_close_port_slot) t)
+          => (cut <> p 'read))))))
+
+(define (close-output-port p)
+  (if (instance? p)
+    (%close-output-port p)
+    (my t (type-of p)
+      (cond
+        ((symbol? t) (raise 'port? p))
+        (((asm NN_pr_record_type_close_port_slot) t)
+         => (cut <> p 'write))))))
+
+(define (close-port p)
+  (if (instance? p)
+    (%close-port p)
+    (my t (type-of p)
+      (cond
+        ((symbol? t) (raise 'port? p))
+        (((asm NN_pr_record_type_close_port_slot) t)
+         => (cut <> p #t))))))
 
 (define (newline (port (current-output-port)))
   (write-char #\newline port)

Index: records.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/records.wisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- records.wisp	18 Sep 2002 21:10:02 -0000	1.8
+++ records.wisp	18 Sep 2002 21:16:49 -0000	1.9
@@ -13,26 +13,38 @@
           (length-hook #f)
           (new-hook #f)
           (read-char-hook #f)
-          (write-char-hook #f))
+          (write-char-hook #f)
+          (read-string-hook #f)
+          (write-string-hook #f)
+          (close-port-hook #f))
       (while (not (null? hooks))
         (my (hook-name hook-generator . rest-hooks) hooks
           (set! hooks rest-hooks)
           (case hook-name
-            ((ref)        (if ref-hook
-                            (raise 'duplicate-ref-hook hook-generator)
-                            (set! ref-hook (apply hook-generator data))))
-            ((length)     (if length-hook
-                            (raise 'duplicate-length-hook hook-generator)
-                            (set! length-hook (apply hook-generator data))))
-            ((new)        (if new-hook
-                            (raise 'duplicate-new-hook hook-generator)
-                            (set! new-hook (apply hook-generator data))))
-            ((read-char)  (if read-char-hook
-                            (raise 'duplicate-read-char-hook hook-generator)
-                            (set! read-char-hook (apply hook-generator data))))
-            ((write-char) (if write-char-hook
-                            (raise 'duplicate-write-char-hook hook-generator)
-                            (set! write-char-hook (apply hook-generator data))))
+            ((ref)          (if ref-hook
+                              (raise 'duplicate-ref-hook hook-generator)
+                              (set! ref-hook (apply hook-generator data))))
+            ((length)       (if length-hook
+                              (raise 'duplicate-length-hook hook-generator)
+                              (set! length-hook (apply hook-generator data))))
+            ((new)          (if new-hook
+                              (raise 'duplicate-new-hook hook-generator)
+                              (set! new-hook (apply hook-generator data))))
+            ((read-char)    (if read-char-hook
+                              (raise 'duplicate-read-char-hook hook-generator)
+                              (set! read-char-hook (apply hook-generator data))))
+            ((write-char)   (if write-char-hook
+                              (raise 'duplicate-write-char-hook hook-generator)
+                              (set! write-char-hook (apply hook-generator data))))
+            ((read-string)  (if read-string-hook
+                             (raise 'duplicate-read-string-hook hook-generator)
+                             (set! read-string-hook (apply hook-generator data))))
+            ((write-string) (if write-string-hook
+                              (raise 'duplicate-write-string-hook hook-generator)
+                              (set! write-string-hook (apply hook-generator data))))
+            ((close-port) (if close-port-hook
+                              (raise 'duplicate-close-port-hook hook-generator)
+                              (set! close-port-hook (apply hook-generator data))))
             (else (raise 'record-hook-name? hook-name)))))
       (if ref-hook
         (set! ((asm NN_pr_record_type_ref_slot) record-type)
@@ -48,5 +60,32 @@
           read-char-hook))
       (if write-char-hook
         (set! ((asm NN_pr_record_type_write_char_slot) record-type)
-          write-char-hook)))
+          write-char-hook))
+      (if read-string-hook
+        (set! ((asm NN_pr_record_type_read_string_slot) record-type)
+          read-string-hook))
+      (if write-string-hook
+        (set! ((asm NN_pr_record_type_write_string_slot) record-type)
+          write-string-hook))
+      (if close-port-hook
+        (set! ((asm NN_pr_record_type_close_port_slot) record-type)
+          close-port-hook)))
     data))
+
+(define (input-mode rt)
+  (let ((c ((asm NN_pr_record_type_read_char_slot) rt))
+        (s ((asm NN_pr_record_type_read_string_slot) rt)))
+    (cond
+      ((and c s) #t)
+      (c 'char)
+      (s 'string)
+      (else #f))))
+
+(define (output-mode rt)
+  (let ((c ((asm NN_pr_record_type_write_char_slot) rt))
+        (s ((asm NN_pr_record_type_write_string_slot) rt)))
+    (cond
+      ((and c s) #t)
+      (c 'char)
+      (s 'string)
+      (else #f))))

Index: stdenv.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/stdenv.wisp,v
retrieving revision 1.370
retrieving revision 1.371
diff -u -d -r1.370 -r1.371
--- stdenv.wisp	18 Sep 2002 21:15:21 -0000	1.370
+++ stdenv.wisp	18 Sep 2002 21:16:49 -0000	1.371
@@ -11,12 +11,12 @@
      (metacode
        (cons 'list
          (map (lambda (x) `(cons ',x ,x))
-           '(* + - / /= < << <= <box> <c16string> <class> <file>
-             <macro> <port> <record-type> <u8vector> <vector> = > >= >>
-             abs acons! address-of alist->dict alist-copy analyse and
-             append append-reverse apply assert assert-object-type
-             assoc assq assv atom? big-integer? bind bit? boolean?
-             box-empty! box-empty? box-ref box? broketed?
+           '(* + - / /= < << <= <box> <c16string> <class> <macro>
+             <old-file> <old-port> <record-type> <u8vector> <vector> =
+             > >= >> abs acons! address-of alist->dict alist-copy
+             analyse and append append-reverse apply assert
+             assert-object-type assoc assq assv atom? big-integer? bind
+             bit? boolean? box-empty! box-empty? box-ref box? broketed?
              builtin-modules c16string? c8string? caaaar caaadr caaar
              caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr
              caddr cadr call-with-in/out-files call-with-input-file
@@ -54,17 +54,18 @@
              fit-for-symbol? fit-for-variable-name? fixnum? flatten
              floor for-all-env-vars for-dir-entries for-each fourth
              fraction? frer->structure hache hide* incr! init-port
-             input-port? instance? integer->char integer->string
-             integer? intermingle keyword? lambda-pack last-cons length
-             let let* letrec list list->semideque list->vector
-             list-copy list-ref list? load lookup-slot macro->procedure
-             macro? make-box make-c16string make-c8string make-class
-             make-counter make-dict make-instance make-record-type
-             make-string make-vector map meaning member memq memv
-             metacode modify-bit module module-ref modulo my-port
-             native? negative? new newline ninth not null-list? null?
-             number->string number? numerator nybble? nyp? odd?
-             open-input-file open-output-file opt or order->dict
+             input-mode input-port? instance? integer->char
+             integer->string integer? intermingle keyword? lambda-pack
+             last-cons length let let* letrec list list->semideque
+             list->vector list-copy list-ref list? load lookup-slot
+             macro->procedure macro? make-box make-c16string
+             make-c8string make-class make-counter make-dict
+             make-instance make-record-type make-string make-vector map
+             meaning member memq memv metacode modify-bit module
+             module-ref modulo my-port native? negative? new newline
+             ninth not null-list? null? number->string number?
+             numerator nybble? nyp? odd? open-input-file
+             open-output-file opt or order->dict output-mode
              output-port? pack-be-integer pack-le-integer
              parse-character-body parse-lambda-list peek-char
              peek-string pick-dict-items port? positive? prep
@@ -74,12 +75,12 @@
              read-character-body read-directory read-line read-string
              read-whole-file real? rec record-type-discriminator
              record-type? reduce-index ref remainder reverse round
-             run-ewisp-file sbyte? second seek semideque
-             semideque->list semideque-bottom semideque-insert!
-             semideque-pop! semideque-push! semideque-top serial
-             seventh signal sixth slice split-by-char string
-             string->c16string string->c8string string->integer
-             string->list string->number string->symbol string-append
+             run-ewisp-file sbyte? second semideque semideque->list
+             semideque-bottom semideque-insert! semideque-pop!
+             semideque-push! semideque-top serial seventh signal sixth
+             slice split-by-char string string->c16string
+             string->c8string string->integer string->list
+             string->number string->symbol string-append
              string-concatenate string-copy string-downcase
              string-downcase! string-fill! string-join string-move!
              string-null? string-template string-upcase string-upcase!

Index: tostring.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/tostring.wisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- tostring.wisp	18 Sep 2002 21:15:23 -0000	1.81
+++ tostring.wisp	18 Sep 2002 21:16:49 -0000	1.82
@@ -233,14 +233,18 @@
                                              (loop (superclass c) (+ g 1))
                                              g))))
                   (emit #\>))
+                ((eq? (type-of s) <file>)
+                  (emit "#<file ")
+                  (emit (integer->string (file-descriptor s)))
+                  (emit #\>))
                 ((instance? s)
                   (cond
                     ((file? s)
-                      (emit "#<file ")
+                      (emit "#<old-file ")
                       (emit (integer->string (file-descriptor s)))
                       (emit #\>))
                     ((port? s)
-                      (emit "#<port ")
+                      (emit "#<old-port ")
                       (emit (stringify-address s))
                       (emit #\>))
                     (else