[Wisp-cvs] wisp/src/builtin filing.wisp,1.110,1.111 init.wisp,1.62,1.63 records.wisp,1.9,1.10 stdenv.wisp,1.371,1.372

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

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

Modified Files:
	filing.wisp init.wisp records.wisp stdenv.wisp 
Log Message:
Created the beginnings of port wrapping.

Index: filing.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/filing.wisp,v
retrieving revision 1.110
retrieving revision 1.111
diff -u -d -r1.110 -r1.111
--- filing.wisp	18 Sep 2002 21:16:49 -0000	1.110
+++ filing.wisp	18 Sep 2002 21:18:04 -0000	1.111
@@ -235,6 +235,40 @@
       (%file-descriptor file)
       (%file-fd file))))
 
+(my (%<output-buffered-port> %make-obp %obp-host %obp-buffer %obp-bufptr)
+  (make-record-type 3
+    'new (lambda (%<obp> %make-obp %obp-host %obp-buffer %obp-bufptr)
+           (lambda (host buffer-type buffer-size)
+             (%make-obp host (new buffer-type buffer-size) 0)))
+    'confess (lambda (%<obp> %make-obp %obp-host %obp-buffer %obp-bufptr)
+               (lambda (port . rest)
+                 (apply
+                   (lambda-pack
+                     ((host) (%obp-host port))
+                     (else #f))
+                   rest)))
+    'aux (lambda (%<obp> %make-obp %obp-host %obp-buffer %obp-bufptr)
+           (lambda (port . rest)
+             (apply
+               (lambda-pack
+                 ((flush)
+                   (if (not (zero? (%obp-bufptr port)))
+                     (begin
+                       (write-string (substring (%obp-buffer port)
+                                                0 (%obp-bufptr port))
+                                     (%obp-host port))
+                       (set! (%obp-bufptr port) 0))))
+                 (else (raise 'output-buffered-port-aux? else)))
+               rest)))
+    'read-char (lambda (%<obp> %make-obp %obp-host %obp-buffer %obp-bufptr)
+                 (lambda (port)
+                   (aux port 'flush)
+                   (read-char (%obp-host port))))
+    'read-string (lambda (%<obp> %make-obp %obp-host %obp-buffer %obp-bufptr)
+                   (lambda (port amount)
+                     (aux port 'flush)
+                     (read-string (%obp-host port) amount)))))
+
 (define (construct-filename dir base)
   (cond
     ((not dir)            base)
@@ -242,6 +276,20 @@
     ((string=? dir ".")   base)
     ((char=? dir[-1] #\/) (string-append dir base))
     (else                 (string-append dir #\/ base))))
+
+; 'host' is a term used for the port being wrapped in the context
+; of port wrapping.  Note that the user isn't supposed to get direct
+; access to the wrapped port but the host-tracking is needed in
+; order to associate ports with file descriptors through the wrapping
+; (and possibly several layers of it).
+
+(define (%port-host port)
+  (let (loop (p port) (visited '()))
+    (cond
+      ((memq p visited) (raise 'port-loop port))
+      ((%confess p 'host) => (lambda (q)
+                               (loop q (cons p visited))))
+      (else p))))
 
 (define (%fd->port fd)
   (my port (make-instance <old-file>)

Index: init.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/init.wisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- init.wisp	18 Sep 2002 21:13:37 -0000	1.62
+++ init.wisp	18 Sep 2002 21:18:04 -0000	1.63
@@ -52,7 +52,9 @@
       (begin
         (set! (dict-ref *user-dictionary* 'assemble) assemble)
         (set! (dict-ref *user-dictionary* 'instruction-list)
-          (map car IHAL)))
+          (map car IHAL))
+        (set! (dict-ref *user-dictionary* 'confess) %confess)
+        (set! (dict-ref *user-dictionary* 'port-host) %port-host))
       (set! (car *asm-lock*) #t))
     ; if the script name ends with a slash, look it up in WISP_PATH
     (if (and (string? script) (not (string-null? script))

Index: records.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/records.wisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- records.wisp	18 Sep 2002 21:16:49 -0000	1.9
+++ records.wisp	18 Sep 2002 21:18:04 -0000	1.10
@@ -16,7 +16,9 @@
           (write-char-hook #f)
           (read-string-hook #f)
           (write-string-hook #f)
-          (close-port-hook #f))
+          (close-port-hook #f)
+          (aux-hook #f)
+          (confess-hook #f))
       (while (not (null? hooks))
         (my (hook-name hook-generator . rest-hooks) hooks
           (set! hooks rest-hooks)
@@ -45,6 +47,12 @@
             ((close-port) (if close-port-hook
                               (raise 'duplicate-close-port-hook hook-generator)
                               (set! close-port-hook (apply hook-generator data))))
+            ((aux) (if aux-hook
+                     (raise 'duplicate-aux-hook hook-generator)
+                     (set! aux-hook (apply hook-generator data))))
+            ((confess) (if confess-hook
+                         (raise 'duplicate-confess-hook hook-generator)
+                         (set! confess-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)
@@ -69,7 +77,13 @@
           write-string-hook))
       (if close-port-hook
         (set! ((asm NN_pr_record_type_close_port_slot) record-type)
-          close-port-hook)))
+          close-port-hook))
+      (if aux-hook
+        (set! ((asm NN_pr_record_type_aux_slot) record-type)
+          aux-hook))
+      (if confess-hook
+        (set! ((asm NN_pr_record_type_confess_slot) record-type)
+          confess-hook)))
     data))
 
 (define (input-mode rt)
@@ -89,3 +103,17 @@
       (c 'char)
       (s 'string)
       (else #f))))
+
+; |aux| and |%confess| are similar in function but with one important
+; difference: |%confess| is meant for private communication between
+; the Wisp and objects while |aux| is for public communication between
+; objects and their clients.
+(define (aux obj . args)
+  (and (type-of obj) -> t => record-type?
+       ((asm NN_pr_record_type_aux_slot) t)
+       => (cut apply <> obj args)))
+
+(define (%confess obj . args)
+  (and (type-of obj) -> t => record-type?
+       ((asm NN_pr_record_type_confess_slot) t)
+       => (cut apply <> obj args)))

Index: stdenv.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/stdenv.wisp,v
retrieving revision 1.371
retrieving revision 1.372
diff -u -d -r1.371 -r1.372
--- stdenv.wisp	18 Sep 2002 21:16:49 -0000	1.371
+++ stdenv.wisp	18 Sep 2002 21:18:04 -0000	1.372
@@ -15,22 +15,22 @@
              <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
-             call-with-output-file car car! car* cardinal? case catch
-             cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr
-             cddar cdddar cddddr cdddr cddr cdr cdr! cdr* ceiling
-             cfmakeraw char->control-char char->integer char-and
-             char-bit-clear char-bit-set char-bit-toggle char-bit?
-             char-decimal? char-digit? char-downcase char-hexadecimal?
-             char-letter-modifier? char-letter? char-lower-case?
-             char-mirrored? char-number-letter? char-octal? char-or
-             char-order char-punctuation-close?
-             char-punctuation-connector? char-punctuation-dash?
-             char-punctuation-final-quote?
+             assert-object-type assoc assq assv atom? aux 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 call-with-output-file car car! car*
+             cardinal? case catch cdaaar cdaadr cdaar cdadar cdaddr
+             cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr
+             cdr cdr! cdr* ceiling cfmakeraw char->control-char
+             char->integer char-and char-bit-clear char-bit-set
+             char-bit-toggle char-bit? char-decimal? char-digit?
+             char-downcase char-hexadecimal? char-letter-modifier?
+             char-letter? char-lower-case? char-mirrored?
+             char-number-letter? char-octal? char-or char-order
+             char-punctuation-close? char-punctuation-connector?
+             char-punctuation-dash? char-punctuation-final-quote?
              char-punctuation-initial-quote? char-punctuation-open?
              char-punctuation? char-ready? char-symbol-currency?
              char-symbol-math? char-symbol-starter? char-symbol?
@@ -112,8 +112,9 @@
                           (list (car mec)
                                 'use module-name))
                      (loop (cdr modules)))))))
-       ; finally, the special case
+       ; finally, the special cases
        ((eq? obj assemble) (cons 'assemble '-A))
+       ((eq? obj %confess) (cons 'confess '-A))
        (else #f)))
    ((*regular-env)
      (my e (alist->dict invariably-regular-items)