wisp-cvs

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

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

Modified Files:
	Makefile.am ORDER modular.wisp stdenv.wisp tostring.wisp 
Added Files:
	fluids.wisp 
Log Message:
Implemented fluid cells.

--- NEW FILE: fluids.wisp ---
;;;; fluid.wim - fluid bindings
;;
;; Copyleft © 2002 by Andres Soolo (di...@us...)
;; This file is licensed under the GNU GPL v2.  If you
;; don't know what that means, please do read the GPL.
;;
;;;; @(#) $Id: fluids.wisp,v 1.1 2002/09/04 14:36:25 digg Exp $

; FIXME: There should be one such alist for each thread.
(define fluid-list (make-box '()))

(my (%<fluid> %make-fluid)
  (make-record-type 0
    'ref (lambda (%<fluid> %make-fluid)
           (lambda (f (:= x))
             (my c (assq f fluid-list[])
               (if (not c) ; not bound in this thread
                 (raise 'wrong-fluid f))
               (if :=?
                 (set! (cadr c) x)
                 (cadr c))))))
  (define <fluid> %<fluid>)

  (define (make-fluid datum)
    (my f (%make-fluid)
      (acons! fluid-list[] f (list datum))
      f))

  (define (with-fluid f datum thunk)
    (my c (assq f fluid-list[])
      (my old-list (cdr c)
        (set! (cdr c) (cons datum old-list))
        (try (thunk)
          (finally (set! (cdr c) old-list)))))))

(defmacro (fluid-my f datum . body)
  `(with-fluid ,f ,datum (lambda #f ,@body)))

(define fluid? (record-type-discriminator <fluid>))

Index: Makefile.am
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/Makefile.am,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- Makefile.am	4 Sep 2002 14:29:47 -0000	1.38
+++ Makefile.am	4 Sep 2002 14:36:25 -0000	1.39
@@ -9,8 +9,9 @@
 EXTRA_DIST = ORDER .cvsignore \
     analyse.wisp assembler.wisp assert.wisp bits.wisp builtin.wisp \
     case.wisp codegen.wisp cut.wisp cxr.wisp dictbase.wisp ewisp.wisp \
-    filing.wisp frer.wisp init.wisp lambda-parser.wisp lists.wisp \
-    locals.wisp macrobase.wisp modular.wisp pack.wisp parser.wisp \
-    preproc.wisp objects.wisp rec.wisp records.wisp semideque.wisp \
-    serial.wisp stdenv.wisp strings.wisp symbols.wisp sys.wisp \
-    sysconst.wisp sysenv.wisp tostring.wisp unix.wisp vectors.wisp
+    filing.wisp fluids.wisp frer.wisp init.wisp lambda-parser.wisp \
+    lists.wisp locals.wisp macrobase.wisp modular.wisp pack.wisp \
+    parser.wisp preproc.wisp objects.wisp rec.wisp records.wisp \
+    semideque.wisp serial.wisp stdenv.wisp strings.wisp symbols.wisp \
+    sys.wisp sysconst.wisp sysenv.wisp tostring.wisp unix.wisp \
+    vectors.wisp

Index: ORDER
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/ORDER,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- ORDER	4 Sep 2002 14:29:47 -0000	1.47
+++ ORDER	4 Sep 2002 14:36:25 -0000	1.48
@@ -23,6 +23,7 @@
 strings.wisp
 pack.wisp
 sys.wisp # depends on strings.wisp, chars.wisp, pack.wisp
+fluids.wisp
 filing.wisp # depends on objects.wisp
 frer.wisp
 modular.wisp

Index: modular.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/modular.wisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- modular.wisp	4 Sep 2002 14:30:56 -0000	1.62
+++ modular.wisp	4 Sep 2002 14:36:25 -0000	1.63
@@ -37,32 +37,41 @@
               exports)
     (pick-dict-items home-dict exports)))
 
-(define modules ; a box containing an alist
-  (make-box
-    (list
-      ; builtin modules
-      (cons 'syscalls
-        (metacode
-          (cons 'list
-            (map (lambda (x) `(cons ',x ,x))
-              '(fdset-ref make-fdset sys:chdir sys:chmod sys:close
-                sys:dup sys:dup2 sys:errno->name sys:execve sys:exit
-                sys:fcntl:cloexec sys:fcntl:dupfd sys:fcntl:flags
-                sys:fcntl:getlk sys:fcntl:setlk sys:fcntl:setlkw
-                sys:for-dir-entries sys:fork sys:fstat sys:ftruncate
-                sys:getcwd sys:getegid sys:geteuid sys:getgid
-                sys:getpgid sys:getpgrp sys:getpid sys:getppid
-                sys:getuid sys:kill sys:link sys:listen sys:lseek
-                sys:lstat sys:mkdir sys:nanosleep sys:open sys:pipe
-                sys:read sys:rename sys:select sys:setpgid sys:setpgrp
-                sys:setsid sys:stat sys:symlink sys:sync sys:tcgetattr
-                sys:tcsetattr sys:truncate sys:unlink sys:waitpid
-                sys:write)))))
-      (cons 'semiraw-files
-        (metacode
-          (cons 'list
-            (map (lambda (x) `(cons ',x ,x))
-              '(init-input-file init-output-file))))))))
+(my builtin-module-data
+  (list
+    (cons 'fluids
+      (metacode
+        (cons 'list
+          (map (lambda (x) `(cons ',x ,x))
+            '(<fluid> fluid-my make-fluid with-fluid)))))
+    (cons 'semiraw-files
+      (metacode
+        (cons 'list
+          (map (lambda (x) `(cons ',x ,x))
+            '(init-input-file init-output-file)))))
+    (cons 'syscalls
+      (metacode
+        (cons 'list
+          (map (lambda (x) `(cons ',x ,x))
+            '(fdset-ref make-fdset sys:chdir sys:chmod sys:close
+              sys:dup sys:dup2 sys:errno->name sys:execve sys:exit
+              sys:fcntl:cloexec sys:fcntl:dupfd sys:fcntl:flags
+              sys:fcntl:getlk sys:fcntl:setlk sys:fcntl:setlkw
+              sys:for-dir-entries sys:fork sys:fstat sys:ftruncate
+              sys:getcwd sys:getegid sys:geteuid sys:getgid
+              sys:getpgid sys:getpgrp sys:getpid sys:getppid
+              sys:getuid sys:kill sys:link sys:listen sys:lseek
+              sys:lstat sys:mkdir sys:nanosleep sys:open sys:pipe
+              sys:read sys:rename sys:select sys:setpgid sys:setpgrp
+              sys:setsid sys:stat sys:symlink sys:sync sys:tcgetattr
+              sys:tcsetattr sys:truncate sys:unlink sys:waitpid
+              sys:write))))))
+
+  (define modules ; a box containing an alist
+    (make-box builtin-module-data))
+
+  (define (builtin-modules)
+    (map car builtin-module-data)))
 
 (define (%get-module module-name)
   (my exportion (and (assq module-name modules[]) => cdr)

Index: stdenv.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/stdenv.wisp,v
retrieving revision 1.357
retrieving revision 1.358
diff -u -d -r1.357 -r1.358
--- stdenv.wisp	4 Sep 2002 14:30:56 -0000	1.357
+++ stdenv.wisp	4 Sep 2002 14:36:25 -0000	1.358
@@ -17,20 +17,20 @@
              analyse and append append-reverse apply assert
              assert-object-type assoc assq assv atom? big-integer? bind
              bit? bitstring-ref boolean? box-empty! box-empty? box-ref
-             box? broketed? 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?
+             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?

Index: tostring.wisp
===================================================================
RCS file: /cvsroot/wisp/wisp/src/builtin/tostring.wisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- tostring.wisp	4 Sep 2002 14:33:35 -0000	1.75
+++ tostring.wisp	4 Sep 2002 14:36:26 -0000	1.76
@@ -263,6 +263,13 @@
                              (loop datum))
                         (except (undefined)
                           (emit #\.))))))
+                ((fluid? s)
+                  ; Note that we won't print the contents of the fluid cell
+                  (if (not (check-duplicity s))
+                    (begin
+                      (emit "#<fluid ")
+                      (emit (stringify-address s))
+                      (emit #\>))))
                 (else (emit "#<??? ")
                       (emit (stringify-address s))
                       (emit #\>))))))))))