From 2c12e14fa553869f85fd250d8771d3b9807d3ef8 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Tue, 16 Oct 1990 21:03:42 +0000 Subject: [PATCH] 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. --- v7/src/runtime/io.scm | 31 ++++- v7/src/runtime/record.scm | 240 ++++++++++++++++++------------------- v7/src/runtime/runtime.pkg | 11 +- v7/src/runtime/version.scm | 4 +- v8/src/runtime/runtime.pkg | 11 +- 5 files changed, 166 insertions(+), 131 deletions(-) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index 2d12bddff..90cde5eeb 100644 --- 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))) -;;;; 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))))))) +;;;; 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)) + +;;;; 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)) - + (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 5a4badc14..1480502d8 100644 --- 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)) (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)) - -(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)))))) + +(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 f020b003d..726c54c8e 100644 --- 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 74292f52a..edd868b26 100644 --- 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 676da291b..d7be0a148 100644 --- 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!))) -- 2.25.1