This runtime requires microcode 11.49 or later.

* Take advantage of new primitives for terminals by adding operations
  to console input and output that use them.

* Define new arithmetic operations:

    FIX:<=
    FIX:>=
    INT:<=
    INT:>=

* Change record package so that record types do not contain
  procedures.  This is needed to permit records and record types to be
  fasdumped.

diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm
index 2d12bddff666db732b205d48888301e1e40d4984..90cde5eeb9877faf5b6c4a4d3c7aa6594e1908c7 100644 (file)
--- a/v7/src/runtime/io.scm
+++ b/v7/src/runtime/io.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.8 1990/08/16 20:09:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.9 1990/10/16 21:03:07 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -160,7 +160,7 @@ MIT in each case. |#
   (if (not traversing?)
       ((ucode-primitive close-lost-open-files 1) open-channels-list)))
 \f
-;;;; Wrapped Primitives
+;;;; Channel Primitives
 
 (define (channel-read channel buffer start end)
   ((ucode-primitive channel-read 4) (channel-descriptor channel)
@@ -219,6 +219,8 @@ MIT in each case. |#
         (and descriptors
              (vector-map descriptors descriptor->channel)))))))
 \f
+;;;; File Primitives
+
 (define (file-open-input-channel filename)
   (without-interrupts
    (lambda ()
@@ -259,6 +261,14 @@ MIT in each case. |#
 (define (file-set-position channel position)
   ((ucode-primitive file-set-position 2) (channel-descriptor channel)
                                         position))
+\f
+;;;; Terminal Primitives
+
+(define (terminal-raw-output channel)
+  ((ucode-primitive terminal-raw-output 1) (channel-descriptor channel)))
+
+(define (terminal-cooked-output channel)
+  ((ucode-primitive terminal-cooked-output 1) (channel-descriptor channel)))
 
 (define (terminal-buffered? channel)
   ((ucode-primitive terminal-buffered? 1) (channel-descriptor channel)))
@@ -278,6 +288,14 @@ MIT in each case. |#
 (define (terminal-drain-output channel)
   ((ucode-primitive terminal-drain-output 1) (channel-descriptor channel)))
 
+(define (terminal-input-baud-rate channel)
+  ((ucode-primitive baud-index->rate 1)
+   ((ucode-primitive terminal-get-ispeed 1) (channel-descriptor channel))))
+
+(define (terminal-output-baud-rate channel)
+  ((ucode-primitive baud-index->rate 1)
+   ((ucode-primitive terminal-get-ospeed 1) (channel-descriptor channel))))
+
 (define (open-pty-master)
   (without-interrupts
    (lambda ()
@@ -364,6 +382,9 @@ MIT in each case. |#
     (set-output-buffer/string! buffer string)
     (if (= position buffer-size) (output-buffer/drain buffer))))
 
+(define output-buffer/buffered-chars
+  output-buffer/position)
+
 (define (output-buffer/drain buffer)
   (let ((position (output-buffer/position buffer)))
     (if (zero? position)
@@ -383,7 +404,7 @@ MIT in each case. |#
 
 (define (output-buffer/flush buffer)
   (set-output-buffer/position! buffer 0))
-
+\f
 (define (output-buffer/write-substring buffer string start end)
   (if (= start end)
       0
@@ -485,7 +506,7 @@ MIT in each case. |#
     (if (< (input-buffer/start-index buffer) end-index)
        (set-input-buffer/start-index! buffer end-index))))
 
-(define (input-buffer/chars-available buffer)
+(define (input-buffer/buffered-chars buffer)
   (- (input-buffer/end-index buffer) (input-buffer/start-index buffer)))
 
 (define (input-buffer/chars-remaining buffer)
@@ -493,7 +514,7 @@ MIT in each case. |#
     (and (channel-type=file? channel)
         (let ((n (- (file-length channel) (file-position channel))))
           (and (not (negative? n))
-               (+ (input-buffer/chars-available buffer) n))))))
+               (+ (input-buffer/buffered-chars buffer) n))))))
 
 (define (input-buffer/char-ready? buffer interval)
   (let ((fill

diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm
index 5a4badc144a197314ea74384020aef379945bad8..1480502d8936b2ec82d2c7ed99f5515617185984 100644 (file)
--- a/v7/src/runtime/record.scm
+++ b/v7/src/runtime/record.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.6 1990/10/04 02:41:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.7 1990/10/16 21:03:14 cph Rel $
 
 Copyright (c) 1989, 1990 Massachusetts Institute of Technology
 
@@ -33,156 +33,152 @@ promotional, or sales literature without prior written consent from
 MIT in each case. |#
 
 ;;;; Records
+;;; package: (runtime record)
+
 ;;; adapted from JAR's implementation
 ;;; conforms to R4RS proposal
 
 (declare (usual-integrations))
 \f
 (define (make-record-type type-name field-names)
-  (let ((size (+ (length field-names) 1))
-       (the-descriptor (make-vector 7)))
-
-    (define (predicate object)
-      (and (vector? object)
-          (= (vector-length object) size)
-          (eq? (vector-ref object 0) the-descriptor)))
-
-    (define (guarantee record procedure-name)
-      (if (not (predicate record))
-         (error:illegal-datum record procedure-name)))
-
-    (define (field-index name procedure-name)
-      (let loop ((names field-names) (index 1))
-       (if (null? names)
-           (error:datum-out-of-range name procedure-name))
-       (if (eq? name (car names))
-           index
-           (loop (cdr names) (+ index 1)))))
-
-    (vector-set! the-descriptor 0 "record-type-descriptor")
-    (vector-set! the-descriptor 1 predicate)
-    (vector-set! the-descriptor 2
-      (lambda (names)
-       (let ((number-of-inits (length names))
-             (indexes
-              (map (lambda (name)
-                     (field-index name 'RECORD-CONSTRUCTOR))
-                   names)))
-         (lambda field-values
-           (if (not (= (length field-values) number-of-inits))
-               (error "wrong number of arguments to record constructor"
-                      field-values type-name names))
-           (let ((record (make-vector size)))
-             (vector-set! record 0 the-descriptor)
-             (for-each (lambda (index value)
-                         (vector-set! record index value))
-                       indexes
-                       field-values)
-             record)))))
-    (vector-set! the-descriptor 3
-      (lambda (name)
-       (let ((index (field-index name 'RECORD-ACCESSOR))
-             (procedure-name `(RECORD-ACCESSOR ,the-descriptor ',name)))
-         (lambda (record)
-           (guarantee record procedure-name)
-           (vector-ref record index)))))
-    (vector-set! the-descriptor 4
-      (lambda (name)
-       (let ((index (field-index name 'RECORD-UPDATER))
-             (procedure-name `(RECORD-UPDATER ,the-descriptor ',name)))
-         (lambda (record new-value)
-           (guarantee record procedure-name)
-           (vector-set! record index new-value)))))
-    (vector-set! the-descriptor 5 type-name)
-    (vector-set! the-descriptor 6 (list-copy field-names))
-    (unparser/set-tagged-vector-method! the-descriptor
+  (let ((record-type
+        (vector record-type-marker type-name (list-copy field-names))))
+    (unparser/set-tagged-vector-method! record-type
                                        (unparser/standard-method type-name))
-    (named-structure/set-tag-description! the-descriptor
+    (named-structure/set-tag-description! record-type
       (letrec ((description
-               (lambda (record)
-                 (guarantee record description)
-                 (map (lambda (name)
-                        (list name
-                              (vector-ref record
-                                          (field-index name description))))
-                      field-names))))
+               (let ((predicate (record-predicate record-type)))
+                 (lambda (record)
+                   (if (not (predicate record))
+                       (error:illegal-datum record description))
+                   (map (lambda (field-name)
+                          (list field-name
+                                (vector-ref
+                                 record
+                                 (record-type-field-index record-type
+                                                          field-name
+                                                          description))))
+                        (vector-ref record-type 2))))))
        description))
-    the-descriptor))
-\f
-(define (record-constructor record-type #!optional field-names)
-  (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-CONSTRUCTOR))
-  ((vector-ref record-type 2)
-   (if (default-object? field-names)
-       (record-type-field-names record-type)
-       field-names)))
+    record-type))
 
-(define (record-predicate record-type)
+(define (record-type? object)
+  (and (vector? object)
+       (= (vector-length object) 3)
+       (eq? (vector-ref object 0) record-type-marker)))
+
+(define (record-type-name record-type)
   (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-PREDICATE))
+      (error:illegal-datum record-type 'RECORD-TYPE-NAME))
   (vector-ref record-type 1))
 
-(define (record-accessor record-type field-name)
+(define (record-type-field-names record-type)
   (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-ACCESSOR))
-  ((vector-ref record-type 3) field-name))
+      (error:illegal-datum record-type 'RECORD-TYPE-FIELD-NAMES))
+  (list-copy (vector-ref record-type 2)))
 
-(define (record-updater record-type field-name)
-  (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-UPDATER))
-  ((vector-ref record-type 4) field-name))
+(define-integrable (record-type-record-length record-type)
+  (+ (length (vector-ref record-type 2)) 1))
+
+(define (record-type-field-index record-type field-name procedure-name)
+  (let loop ((field-names (vector-ref record-type 2)) (index 1))
+    (if (null? field-names)
+       (error:datum-out-of-range field-name procedure-name))
+    (if (eq? field-name (car field-names))
+       index
+       (loop (cdr field-names) (+ index 1)))))
 
 (define (set-record-type-unparser-method! record-type method)
   (if (not (record-type? record-type))
       (error:illegal-datum record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!))
   (unparser/set-tagged-vector-method! record-type method))
 
-;;; Abstraction-Breaking Operations
-
-(define record-type?)
+(define record-type-marker)
 
 (define (initialize-package!)
-  (let ((record-type (make-record-type "foo" '())))
-    (let ((size (vector-length record-type))
-         (tag (vector-ref record-type 0)))
-      (unparser/set-tagged-vector-method!
-       tag
-       (unparser/standard-method 'RECORD-TYPE-DESCRIPTOR
-        (lambda (state record-type)
-          (unparse-object state (vector-ref record-type 5)))))
-      (named-structure/set-tag-description! tag
-       (lambda (record-type)
-         (if (not (record-type? record-type))
-             (error:illegal-datum record-type false))
-         `((PREDICATE ,(vector-ref record-type 1))
-           (CONSTRUCTOR-CONSTRUCTOR ,(vector-ref record-type 2))
-           (ACCESSOR-CONSTRUCTOR ,(vector-ref record-type 3))
-           (UPDATER-CONSTRUCTOR ,(vector-ref record-type 4))
-           (TYPE-NAME ,(vector-ref record-type 5))
-           (FIELD-NAMES ,(vector-ref record-type 6)))))
-      (set! record-type?
-           (lambda (object)
-             (and (vector? object)
-                  (= (vector-length object) size)
-                  (eq? (vector-ref object 0) tag))))))
-  unspecific)
-
-(define (record-type-name record-type)
-  (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-TYPE-NAME))
-  (vector-ref record-type 5))
-
-(define (record-type-field-names record-type)
+  (set! record-type-marker
+       (string->symbol "#[(runtime record)record-type-marker]"))
+  (unparser/set-tagged-vector-method!
+   record-type-marker
+   (unparser/standard-method 'RECORD-TYPE-DESCRIPTOR
+     (lambda (state record-type)
+       (unparse-object state (record-type-name record-type)))))
+  (named-structure/set-tag-description! record-type-marker
+    (lambda (record-type)
+      (if (not (record-type? record-type))
+         (error:illegal-datum record-type false))
+      `((TYPE-NAME ,(record-type-name record-type))
+       (FIELD-NAMES ,(record-type-field-names record-type))))))
+\f
+(define (record-constructor record-type #!optional field-names)
   (if (not (record-type? record-type))
-      (error:illegal-datum record-type 'RECORD-TYPE-FIELD-NAMES))
-  (list-copy (vector-ref record-type 6)))
+      (error:illegal-datum record-type 'RECORD-CONSTRUCTOR))
+  (let ((field-names
+        (if (default-object? field-names)
+            (vector-ref record-type 2)
+            field-names)))
+    (let ((record-length (record-type-record-length record-type))
+         (number-of-inits (length field-names))
+         (indexes
+          (map (lambda (field-name)
+                 (record-type-field-index record-type
+                                          field-name
+                                          'RECORD-CONSTRUCTOR))
+               field-names)))
+      (lambda field-values
+       (if (not (= (length field-values) number-of-inits))
+           (error "wrong number of arguments to record constructor"
+                  field-values record-type field-names))
+       (let ((record (make-vector record-length)))
+         (vector-set! record 0 record-type)
+         (for-each (lambda (index value) (vector-set! record index value))
+                   indexes
+                   field-values)
+         record)))))
 
 (define (record? object)
   (and (vector? object)
-       (not (zero? (vector-length object)))
+       (positive? (vector-length object))
        (record-type? (vector-ref object 0))))
 
 (define (record-type-descriptor record)
   (if (not (record? record))
       (error:illegal-datum record 'RECORD-TYPE-DESCRIPTOR))
-  (vector-ref record 0))
\ No newline at end of file
+  (vector-ref record 0))
+
+(define (record-predicate record-type)
+  (if (not (record-type? record-type))
+      (error:illegal-datum record-type 'RECORD-PREDICATE))
+  (let ((record-length (record-type-record-length record-type)))
+    (lambda (object)
+      (and (vector? object)
+          (= (vector-length object) record-length)
+          (eq? (vector-ref object 0) record-type)))))
+
+(define (record-accessor record-type field-name)
+  (if (not (record-type? record-type))
+      (error:illegal-datum record-type 'RECORD-ACCESSOR))
+  (let ((record-length (record-type-record-length record-type))
+       (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
+       (index
+        (record-type-field-index record-type field-name 'RECORD-ACCESSOR)))
+    (lambda (record)
+      (if (not (and (vector? record)
+                   (= (vector-length record) record-length)
+                   (eq? (vector-ref record 0) record-type)))
+         (error:illegal-datum record procedure-name))
+      (vector-ref record index))))
+
+(define (record-updater record-type field-name)
+  (if (not (record-type? record-type))
+      (error:illegal-datum record-type 'RECORD-UPDATER))
+  (let ((record-length (record-type-record-length record-type))
+       (procedure-name `(RECORD-UPDATER ,record-type ',field-name))
+       (index
+        (record-type-field-index record-type field-name 'RECORD-UPDATER)))
+    (lambda (record field-value)
+      (if (not (and (vector? record)
+                   (= (vector-length record) record-length)
+                   (eq? (vector-ref record 0) record-type)))
+         (error:illegal-datum record procedure-name))
+      (vector-set! record index field-value))))
\ No newline at end of file

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index f020b003d86e69147690181c9ea36b8154990040..726c54c8e3b7a7ce392b1c9b6c6c367c1411f7ec 100644 (file)
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.79 1990/10/04 02:42:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.80 1990/10/16 21:03:20 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -1346,6 +1346,7 @@ MIT in each case. |#
   (export (runtime file-input)
          file-length
          file-open-input-channel
+         input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
          input-buffer/chars-remaining
@@ -1364,6 +1365,7 @@ MIT in each case. |#
          file-open-append-channel
          file-open-output-channel
          make-output-buffer
+         output-buffer/buffered-chars
          output-buffer/close
          output-buffer/drain-block
          output-buffer/set-size
@@ -1371,18 +1373,24 @@ MIT in each case. |#
          output-buffer/write-char-block
          output-buffer/write-string-block)
   (export (runtime console-output)
+         channel-type=terminal?
          channel-write-char-block
          channel-write-string-block
          make-output-buffer
+         output-buffer/buffered-chars
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
          output-buffer/write-char-block
          output-buffer/write-string-block
+         terminal-cooked-output
+         terminal-output-baud-rate
+         terminal-raw-output
          tty-output-channel)
   (export (runtime console-input)
          channel-type=file?
          channel-type=terminal?
+         input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
          input-buffer/peek-char
@@ -1390,6 +1398,7 @@ MIT in each case. |#
          make-input-buffer
          terminal-buffered
          terminal-buffered?
+         terminal-input-baud-rate
          terminal-nonbuffered
          tty-input-channel)
   (initialization (initialize-package!)))

diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm
index 74292f52aa5136b48d1ad284f2a2a1109ab6f1b7..edd868b26cc958149f6bc468ab23febd389033f0 100644 (file)
--- a/v7/src/runtime/version.scm
+++ b/v7/src/runtime/version.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.98 1990/10/03 21:54:30 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.99 1990/10/16 21:03:42 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -45,7 +45,7 @@ MIT in each case. |#
                     '()))
   (add-system! microcode-system)
   (add-event-receiver! event:after-restore snarf-microcode-version!)
-  (add-identification! "Runtime" 14 98))
+  (add-identification! "Runtime" 14 99))
 
 (define microcode-system)
 

diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg
index 676da291b93152d5916215e703a8d9b4c770b9a2..d7be0a1485a3eb652b9e1bbcf3f1b50248af55cd 100644 (file)
--- a/v8/src/runtime/runtime.pkg
+++ b/v8/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.79 1990/10/04 02:42:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.80 1990/10/16 21:03:20 cph Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -1346,6 +1346,7 @@ MIT in each case. |#
   (export (runtime file-input)
          file-length
          file-open-input-channel
+         input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
          input-buffer/chars-remaining
@@ -1364,6 +1365,7 @@ MIT in each case. |#
          file-open-append-channel
          file-open-output-channel
          make-output-buffer
+         output-buffer/buffered-chars
          output-buffer/close
          output-buffer/drain-block
          output-buffer/set-size
@@ -1371,18 +1373,24 @@ MIT in each case. |#
          output-buffer/write-char-block
          output-buffer/write-string-block)
   (export (runtime console-output)
+         channel-type=terminal?
          channel-write-char-block
          channel-write-string-block
          make-output-buffer
+         output-buffer/buffered-chars
          output-buffer/drain-block
          output-buffer/set-size
          output-buffer/size
          output-buffer/write-char-block
          output-buffer/write-string-block
+         terminal-cooked-output
+         terminal-output-baud-rate
+         terminal-raw-output
          tty-output-channel)
   (export (runtime console-input)
          channel-type=file?
          channel-type=terminal?
+         input-buffer/buffered-chars
          input-buffer/channel
          input-buffer/char-ready?
          input-buffer/peek-char
@@ -1390,6 +1398,7 @@ MIT in each case. |#
          make-input-buffer
          terminal-buffered
          terminal-buffered?
+         terminal-input-baud-rate
          terminal-nonbuffered
          tty-input-channel)
   (initialization (initialize-package!)))