Only remaining such symbols are those that have explicit case.
(lambda (type)
(if (port-type-supports-input? type)
(if (port-type-supports-output? type)
- 'TEXTUAL-I/O-PORT-TYPE
- 'TEXTUAL-INPUT-PORT-TYPE)
+ 'textual-i/o-port-type
+ 'textual-input-port-type)
(if (port-type-supports-output? type)
- 'TEXTUAL-OUTPUT-PORT-TYPE
- 'TEXTUAL-PORT-TYPE)))
+ 'textual-output-port-type
+ 'textual-port-type)))
#f))
(define (port-type-supports-input? type)
(append operations
(remove (let ((excluded
(append
- (if (assq 'READ-CHAR operations)
+ (if (assq 'read-char operations)
standard-input-operation-names
'())
- (if (assq 'WRITE-CHAR operations)
+ (if (assq 'write-char operations)
standard-output-operation-names
'()))))
(lambda (p)
(values (reverse! standard) (reverse! custom)))))
(define standard-input-operation-names
- '(CHAR-READY?
- PEEK-CHAR
- READ-CHAR
- READ-SUBSTRING
- UNREAD-CHAR))
+ '(char-ready?
+ peek-char
+ read-char
+ read-substring
+ unread-char))
(define standard-output-operation-names
- '(WRITE-CHAR
- WRITE-SUBSTRING
- FLUSH-OUTPUT
- DISCRETIONARY-FLUSH-OUTPUT))
+ '(write-char
+ write-substring
+ flush-output
+ discretionary-flush-output))
\f
;;;; Default I/O operations
(error "Missing required operation:" name)))
(define (provide-default-input-operations op)
- (required-operation op 'READ-CHAR)
- (if (and (or (op 'UNREAD-CHAR)
- (op 'PEEK-CHAR))
- (not (and (op 'UNREAD-CHAR)
- (op 'PEEK-CHAR))))
+ (required-operation op 'read-char)
+ (if (and (or (op 'unread-char)
+ (op 'peek-char))
+ (not (and (op 'unread-char)
+ (op 'peek-char))))
(error "Must provide both UNREAD-CHAR and PEEK-CHAR operations."))
(let ((char-ready?
- (or (op 'CHAR-READY?)
+ (or (op 'char-ready?)
(lambda (port) port #t)))
(read-substring
- (or (op 'READ-SUBSTRING)
+ (or (op 'read-substring)
generic-port-operation:read-substring)))
(lambda (name)
(case name
- ((CHAR-READY?) char-ready?)
- ((READ-SUBSTRING) read-substring)
+ ((char-ready?) char-ready?)
+ ((read-substring) read-substring)
(else (op name))))))
(define (generic-port-operation:read-substring port string start end)
(- index start))))))))
(define (provide-default-output-operations op)
- (required-operation op 'WRITE-CHAR)
+ (required-operation op 'write-char)
(let ((write-substring
- (or (op 'WRITE-SUBSTRING)
+ (or (op 'write-substring)
generic-port-operation:write-substring))
(flush-output
- (or (op 'FLUSH-OUTPUT)
+ (or (op 'flush-output)
no-flush))
(discretionary-flush-output
- (or (op 'DISCRETIONARY-FLUSH-OUTPUT)
+ (or (op 'discretionary-flush-output)
no-flush)))
(lambda (name)
(case name
- ((WRITE-SUBSTRING) write-substring)
- ((FLUSH-OUTPUT) flush-output)
- ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
+ ((write-substring) write-substring)
+ ((flush-output) flush-output)
+ ((discretionary-flush-output) discretionary-flush-output)
(else (op name))))))
(define (no-flush port)
(define (provide-input-features op)
(let ((read-char
- (let ((defer (op 'READ-CHAR)))
+ (let ((defer (op 'read-char)))
(lambda (port)
(let ((char (defer port)))
(transcribe-input-char char port)
(set-textual-port-unread?! port #f)
char))))
(unread-char
- (let ((defer (op 'UNREAD-CHAR)))
+ (let ((defer (op 'unread-char)))
(and defer
(lambda (port char)
(defer port char)
(set-textual-port-unread?! port #t)))))
(peek-char
- (let ((defer (op 'PEEK-CHAR)))
+ (let ((defer (op 'peek-char)))
(and defer
(lambda (port)
(let ((char (defer port)))
(set-textual-port-unread?! port #t)
char)))))
(read-substring
- (let ((defer (op 'READ-SUBSTRING)))
+ (let ((defer (op 'read-substring)))
(lambda (port string start end)
(let ((n (defer port string start end)))
(transcribe-input-substring string start n port)
n)))))
(lambda (name)
(case name
- ((READ-CHAR) read-char)
- ((UNREAD-CHAR) unread-char)
- ((PEEK-CHAR) peek-char)
- ((READ-SUBSTRING) read-substring)
+ ((read-char) read-char)
+ ((unread-char) unread-char)
+ ((peek-char) peek-char)
+ ((read-substring) read-substring)
(else (op name))))))
(define (transcribe-input-char char port)
(define (provide-output-features op)
(let ((write-char
- (let ((defer (op 'WRITE-CHAR)))
+ (let ((defer (op 'write-char)))
(lambda (port char)
(let ((n (defer port char)))
(if (and n (fix:> n 0))
(transcribe-char char port)))
n))))
(write-substring
- (let ((defer (op 'WRITE-SUBSTRING)))
+ (let ((defer (op 'write-substring)))
(lambda (port string start end)
(let ((n (defer port string start end)))
(if (and n (> n 0))
(transcribe-substring string start end port)))
n))))
(flush-output
- (let ((defer (op 'FLUSH-OUTPUT)))
+ (let ((defer (op 'flush-output)))
(lambda (port)
(defer port)
(flush-transcript port))))
(discretionary-flush-output
- (let ((defer (op 'DISCRETIONARY-FLUSH-OUTPUT)))
+ (let ((defer (op 'discretionary-flush-output)))
(lambda (port)
(defer port)
(discretionary-flush-transcript port))))
(lambda (port)
(if (textual-port-previous port)
(char=? (textual-port-previous port) #\newline)
- 'UNKNOWN))))
+ 'unknown))))
(let ((fresh-line
(lambda (port)
(if (and (textual-port-previous port)
0))))
(lambda (name)
(case name
- ((WRITE-CHAR) write-char)
- ((WRITE-SUBSTRING) write-substring)
- ((FRESH-LINE) fresh-line)
- ((LINE-START?) line-start?)
- ((FLUSH-OUTPUT) flush-output)
- ((DISCRETIONARY-FLUSH-OUTPUT) discretionary-flush-output)
+ ((write-char) write-char)
+ ((write-substring) write-substring)
+ ((fresh-line) fresh-line)
+ ((line-start?) line-start?)
+ ((flush-output) flush-output)
+ ((discretionary-flush-output) discretionary-flush-output)
(else (op name)))))))
\f
;;;; Textual ports
(define-unparser-method textual-port?
(standard-unparser-method
(lambda (port)
- (cond ((textual-i/o-port? port) 'TEXTUAL-I/O-PORT)
- ((textual-input-port? port) 'TEXTUAL-INPUT-PORT)
- ((textual-output-port? port) 'TEXTUAL-OUTPUT-PORT)
- (else 'TEXTUAL-PORT)))
+ (cond ((textual-i/o-port? port) 'textual-i/o-port)
+ ((textual-input-port? port) 'textual-input-port)
+ ((textual-output-port? port) 'textual-output-port)
+ (else 'textual-port)))
(lambda (port output-port)
- (cond ((textual-port-operation port 'WRITE-SELF)
+ (cond ((textual-port-operation port 'write-self)
=> (lambda (operation)
(operation port output-port)))))))
\f
(define (close-textual-port port)
- (let ((close (textual-port-operation port 'CLOSE)))
+ (let ((close (textual-port-operation port 'close)))
(if close
(close port)
(begin
(close-textual-input-port port)))))
(define (close-textual-input-port port)
- (let ((close-input (textual-port-operation port 'CLOSE-INPUT)))
+ (let ((close-input (textual-port-operation port 'close-input)))
(if close-input
(close-input port))))
(define (close-textual-output-port port)
- (let ((close-output (textual-port-operation port 'CLOSE-OUTPUT)))
+ (let ((close-output (textual-port-operation port 'close-output)))
(if close-output
(close-output port))))
(define (textual-port-open? port)
- (let ((open? (textual-port-operation port 'OPEN?)))
+ (let ((open? (textual-port-operation port 'open?)))
(if open?
(open? port)
(and (if (textual-input-port? port)
#t)))))
(define (textual-input-port-open? port)
- (let ((open? (textual-port-operation port 'INPUT-OPEN?)))
+ (let ((open? (textual-port-operation port 'input-open?)))
(if open?
(open? port)
#t)))
(define (textual-output-port-open? port)
- (let ((open? (textual-port-operation port 'OUTPUT-OPEN?)))
+ (let ((open? (textual-port-operation port 'output-open?)))
(if open?
(open? port)
#t)))
(sc-macro-transformer
(lambda (form environment)
(let ((name (cadr form)))
- `(DEFINE (,(symbol 'TEXTUAL-PORT-OPERATION/ name) PORT)
- (,(close-syntax (symbol 'PORT-TYPE-OPERATION: name) environment)
- (TEXTUAL-PORT-TYPE PORT)))))))
+ `(define (,(symbol 'textual-port-operation/ name) port)
+ (,(close-syntax (symbol 'port-type-operation: name) environment)
+ (textual-port-type port)))))))
(define-port-operation char-ready?)
(define-port-operation read-char)
(output-port/discretionary-flush tport))))
\f
(define (textual-port-char-set port)
- (let ((operation (textual-port-operation port 'CHAR-SET)))
+ (let ((operation (textual-port-operation port 'char-set)))
(if operation
(operation port)
char-set:iso-8859-1)))
(define (port/supports-coding? port)
- (let ((operation (textual-port-operation port 'SUPPORTS-CODING?)))
+ (let ((operation (textual-port-operation port 'supports-coding?)))
(if operation
(operation port)
#f)))
(define (port/coding port)
- ((or (textual-port-operation port 'CODING)
- (error:bad-range-argument port 'PORT/CODING))
+ ((or (textual-port-operation port 'coding)
+ (error:bad-range-argument port 'port/coding))
port))
(define (port/set-coding port name)
- ((or (textual-port-operation port 'SET-CODING)
- (error:bad-range-argument port 'PORT/SET-CODING))
+ ((or (textual-port-operation port 'set-coding)
+ (error:bad-range-argument port 'port/set-coding))
port name))
(define (port/known-coding? port name)
- ((or (textual-port-operation port 'KNOWN-CODING?)
- (error:bad-range-argument port 'PORT/KNOWN-CODING?))
+ ((or (textual-port-operation port 'known-coding?)
+ (error:bad-range-argument port 'port/known-coding?))
port name))
(define (port/known-codings port)
- ((or (textual-port-operation port 'KNOWN-CODINGS)
- (error:bad-range-argument port 'PORT/KNOWN-CODINGS))
+ ((or (textual-port-operation port 'known-codings)
+ (error:bad-range-argument port 'port/known-codings))
port))
(define (port/line-ending port)
- ((or (textual-port-operation port 'LINE-ENDING)
- (error:bad-range-argument port 'PORT/LINE-ENDING))
+ ((or (textual-port-operation port 'line-ending)
+ (error:bad-range-argument port 'port/line-ending))
port))
(define (port/set-line-ending port name)
- ((or (textual-port-operation port 'SET-LINE-ENDING)
- (error:bad-range-argument port 'PORT/SET-LINE-ENDING))
+ ((or (textual-port-operation port 'set-line-ending)
+ (error:bad-range-argument port 'port/set-line-ending))
port name))
(define (port/known-line-ending? port name)
- ((or (textual-port-operation port 'KNOWN-LINE-ENDING?)
- (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDING?))
+ ((or (textual-port-operation port 'known-line-ending?)
+ (error:bad-range-argument port 'port/known-line-ending?))
port name))
(define (port/known-line-endings port)
- ((or (textual-port-operation port 'KNOWN-LINE-ENDINGS)
- (error:bad-range-argument port 'PORT/KNOWN-LINE-ENDINGS))
+ ((or (textual-port-operation port 'known-line-endings)
+ (error:bad-range-argument port 'port/known-line-endings))
port))
\f
;;;; Generic ports
(generation 0))
(define (make-thread-barrier count #!optional name)
- (guarantee exact-positive-integer? count 'MAKE-THREAD-BARRIER)
+ (guarantee exact-positive-integer? count 'make-thread-barrier)
(let ((current count)
(condvar
(make-condition-variable
(%make-thread-barrier count current condvar)))
(define (thread-barrier-wait barrier)
- (guarantee thread-barrier? barrier 'THREAD-BARRIER-WAIT)
+ (guarantee thread-barrier? barrier 'thread-barrier-wait)
(let ((lock (thread-barrier.lock barrier))
(condvar (thread-barrier.condvar barrier)))
(with-thread-mutex-lock lock
(define-syntax %assert
(syntax-rules ()
- ((_ CONDITION)
+ ((_ condition)
#f)))
#;(define-syntax %assert
(syntax-rules ()
- ((_ CONDITION)
- (if (not CONDITION)
- (error "Assertion failed:" 'CONDITION)))))
+ ((_ condition)
+ (if (not condition)
+ (error "Assertion failed:" 'condition)))))
(define-integrable (%locked? queue)
(thread-mutex-owner (%thread-queue/mutex queue)))
(block-events? #f)
;; If #t, events may not run in this thread and should be queued.
- ;; If 'SUSPENDED, events were blocked when the thread suspended.
+ ;; If 'suspended, events were blocked when the thread suspended.
;; Events should wake the thread and %resume-current-thread should
;; run them but then it should continue with events blocked (#t).
(search
descriptor
(case mode
- ((READ) (lambda (mode) (memq mode '(read read/write))))
- ((WRITE) (lambda (mode) (memq mode '(write read/write))))
- ((READ/WRITE) (lambda (mode) mode))
- ((ERROR HANGUP) (lambda (mode) mode #t))
+ ((read) (lambda (mode) (memq mode '(read read/write))))
+ ((write) (lambda (mode) (memq mode '(write read/write))))
+ ((read/write) (lambda (mode) mode))
+ ((error hangup) (lambda (mode) mode #t))
(else (error "Illegal mode:" mode))))))
(if (not dentry)
(loop (fix:+ i 1) events)
(vector-set! dispatch-table
(microcode-type (car entry))
(cadr entry)))
- `((ASSIGNMENT ,unparse/assignment)
- (BIGNUM ,unparse/number)
- (BYTEVECTOR ,unparse/bytevector)
- (CHARACTER ,unparse/character)
- (COMPILED-ENTRY ,unparse/compiled-entry)
- (COMPLEX ,unparse/number)
- (CONSTANT ,unparse/constant)
- (DEFINITION ,unparse/definition)
- (ENTITY ,unparse/entity)
- (EXTENDED-PROCEDURE ,unparse/compound-procedure)
- (FLONUM ,unparse/flonum)
- (INTERNED-SYMBOL ,unparse/interned-symbol)
- (LAMBDA ,unparse/lambda)
- (LIST ,unparse/pair)
- (NEGATIVE-FIXNUM ,unparse/number)
- (FALSE ,unparse/false)
- (POSITIVE-FIXNUM ,unparse/number)
- (PRIMITIVE ,unparse/primitive-procedure)
- (PROCEDURE ,unparse/compound-procedure)
- (PROMISE ,unparse/promise)
- (RATNUM ,unparse/number)
- (RECORD ,unparse/record)
- (RETURN-ADDRESS ,unparse/return-address)
- (STRING ,unparse/string)
- (TAGGED-OBJECT ,unparse/tagged-object)
- (UNICODE-STRING ,unparse/string)
- (UNINTERNED-SYMBOL ,unparse/uninterned-symbol)
- (VARIABLE ,unparse/variable)
- (VECTOR ,unparse/vector)
- (VECTOR-1B ,unparse/bit-string)))))
+ `((assignment ,unparse/assignment)
+ (bignum ,unparse/number)
+ (bytevector ,unparse/bytevector)
+ (character ,unparse/character)
+ (compiled-entry ,unparse/compiled-entry)
+ (complex ,unparse/number)
+ (constant ,unparse/constant)
+ (definition ,unparse/definition)
+ (entity ,unparse/entity)
+ (extended-procedure ,unparse/compound-procedure)
+ (flonum ,unparse/flonum)
+ (interned-symbol ,unparse/interned-symbol)
+ (lambda ,unparse/lambda)
+ (list ,unparse/pair)
+ (negative-fixnum ,unparse/number)
+ (false ,unparse/false)
+ (positive-fixnum ,unparse/number)
+ (primitive ,unparse/primitive-procedure)
+ (procedure ,unparse/compound-procedure)
+ (promise ,unparse/promise)
+ (ratnum ,unparse/number)
+ (record ,unparse/record)
+ (return-address ,unparse/return-address)
+ (string ,unparse/string)
+ (tagged-object ,unparse/tagged-object)
+ (unicode-string ,unparse/string)
+ (uninterned-symbol ,unparse/uninterned-symbol)
+ (variable ,unparse/variable)
+ (vector ,unparse/vector)
+ (vector-1b ,unparse/bit-string)))))
\f
;;;; Low Level Operations
(define (unparse/default object context)
(let ((type (user-object-type object)))
(case (object-gc-type object)
- ((CELL PAIR TRIPLE QUADRUPLE VECTOR COMPILED-ENTRY)
+ ((cell pair triple quadruple vector compiled-entry)
(*unparse-with-brackets type object context #f))
- ((NON-POINTER)
+ ((non-pointer)
(*unparse-with-brackets type object context
(lambda (context*)
(*unparse-datum object context*))))
type-name)))
(define renamed-user-object-types
- '((NEGATIVE-FIXNUM . NUMBER)
- (POSITIVE-FIXNUM . NUMBER)
- (BIGNUM . NUMBER)
- (FLONUM . NUMBER)
- (COMPLEX . NUMBER)
- (INTERNED-SYMBOL . SYMBOL)
- (UNINTERNED-SYMBOL . SYMBOL)
- (EXTENDED-PROCEDURE . PROCEDURE)
- (PRIMITIVE . PRIMITIVE-PROCEDURE)
- (LEXPR . LAMBDA)
- (EXTENDED-LAMBDA . LAMBDA)))
+ '((negative-fixnum . number)
+ (positive-fixnum . number)
+ (bignum . number)
+ (flonum . number)
+ (complex . number)
+ (interned-symbol . symbol)
+ (uninterned-symbol . symbol)
+ (extended-procedure . procedure)
+ (primitive . primitive-procedure)
+ (lexpr . lambda)
+ (extended-lambda . lambda)))
(define (unparse/false object context)
(if (eq? object #f)
(define (unparse/uninterned-symbol symbol context)
(if (get-param:unparse-uninterned-symbols-by-name?)
(unparse-symbol-name (symbol->string symbol) context)
- (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol context
+ (*unparse-with-brackets 'uninterned-symbol symbol context
(lambda (context*)
(*unparse-string (symbol->string symbol) context*)))))
(define (unparse-keyword-name s context)
(case (param:parser-keyword-style)
- ((PREFIX)
+ ((prefix)
(*unparse-char #\: context)
(unparse-symbol-name s context))
- ((SUFFIX)
+ ((suffix)
(unparse-symbol-name s context)
(*unparse-char #\: context))
(else
(char-in-set? (string-ref s 0) char-set:symbol-initial)
(string-every (symbol-name-no-quoting-predicate context) s)
(not (case (param:parser-keyword-style)
- ((PREFIX) (string-prefix? ":" s))
- ((SUFFIX) (string-suffix? ":" s))
+ ((prefix) (string-prefix? ":" s))
+ ((suffix) (string-suffix? ":" s))
(else #f)))
(not (string->number s)))
(*unparse-string s context)
(pair? (safe-cdr object))
(null? (safe-cdr (safe-cdr object)))
(case (safe-car object)
- ((QUOTE) "'")
- ((QUASIQUOTE) "`")
- ((UNQUOTE) ",")
- ((UNQUOTE-SPLICING) ",@")
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@")
(else #f))))
(define (unparse-list/stream-pair stream-pair context)
;;;; Procedures
(define (unparse/compound-procedure procedure context)
- (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure context
+ (*unparse-with-brackets 'compound-procedure procedure context
(and (get-param:unparse-compound-procedure-names?)
(lambda-components* (procedure-lambda procedure)
(lambda (name required optional rest body)
((get-param:unparse-with-maximum-readability?)
(*unparse-readable-hash procedure context))
(else
- (*unparse-with-brackets 'PRIMITIVE-PROCEDURE #f context
+ (*unparse-with-brackets 'primitive-procedure #f context
unparse-name)))))
(define (unparse/compiled-entry entry context)
(let* ((type (compiled-entry-type entry))
- (procedure? (eq? type 'COMPILED-PROCEDURE))
+ (procedure? (eq? type 'compiled-procedure))
(closure?
(and procedure?
(compiled-code-block/manifest-closure?
(compiled-code-address->block entry)))))
- (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type)
+ (*unparse-with-brackets (if closure? 'compiled-closure type)
entry
context
(lambda (context*)
;;;; Miscellaneous
(define (unparse/return-address return-address context)
- (*unparse-with-brackets 'RETURN-ADDRESS return-address context
+ (*unparse-with-brackets 'return-address return-address context
(lambda (context*)
(*unparse-object (return-address/name return-address) context*))))
(define (unparse/assignment assignment context)
- (*unparse-with-brackets 'ASSIGNMENT assignment context
+ (*unparse-with-brackets 'assignment assignment context
(lambda (context*)
(*unparse-object (scode-assignment-name assignment) context*))))
(define (unparse/definition definition context)
- (*unparse-with-brackets 'DEFINITION definition context
+ (*unparse-with-brackets 'definition definition context
(lambda (context*)
(*unparse-object (scode-definition-name definition) context*))))
(define (unparse/lambda lambda-object context)
- (*unparse-with-brackets 'LAMBDA lambda-object context
+ (*unparse-with-brackets 'lambda lambda-object context
(lambda (context*)
(*unparse-object (scode-lambda-name lambda-object) context*))))
(define (unparse/variable variable context)
- (*unparse-with-brackets 'VARIABLE variable context
+ (*unparse-with-brackets 'variable variable context
(lambda (context*)
(*unparse-object (scode-variable-name variable) context*))))
(*unparse-with-brackets name entity context #f))
(define (named-arity-dispatched-procedure name)
- (*unparse-with-brackets 'ARITY-DISPATCHED-PROCEDURE entity context
+ (*unparse-with-brackets 'arity-dispatched-procedure entity context
(lambda (context*)
(*unparse-string name context*))))
(cond ((continuation? entity)
- (plain 'CONTINUATION))
+ (plain 'continuation))
((apply-hook? entity)
- (plain 'APPLY-HOOK))
+ (plain 'apply-hook))
((arity-dispatched-procedure? entity)
(let ((proc (%entity-procedure entity)))
(cond ((and (compiled-code-address? proc)
(compiled-procedure? proc)
(compiled-procedure/name proc))
=> named-arity-dispatched-procedure)
- (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
+ (else (plain 'arity-dispatched-procedure)))))
((get-param:unparse-with-maximum-readability?)
(*unparse-readable-hash entity context))
- (else (plain 'ENTITY))))
+ (else (plain 'entity))))
(define (unparse/promise promise context)
- (*unparse-with-brackets 'PROMISE promise context
+ (*unparse-with-brackets 'promise promise context
(if (promise-forced? promise)
(lambda (context*)
(*unparse-string "(evaluated) " context*)
(define (unsyntax-with-substitutions scode alist)
(if (not (alist? alist))
- (error:wrong-type-argument alist "alist" 'UNSYNTAX-WITH-SUBSTITUTIONS))
+ (error:wrong-type-argument alist "alist" 'unsyntax-with-substitutions))
(parameterize* (list (cons substitutions alist))
(lambda ()
(unsyntax scode))))
(symbol? object)
(vector? object))
;; R4RS quoted data (in addition to above)
- `(QUOTE ,object))
+ `(quote ,object))
((compiled-expression? object)
(let ((scode (compiled-expression/scode object)))
(if (eq? scode object)
- `(SCODE-QUOTE ,object)
+ `(scode-quote ,object)
(unsyntax-object environment scode))))
(else
object)))
-(define (unsyntax-QUOTATION environment quotation)
- `(SCODE-QUOTE
+(define (unsyntax-quotation environment quotation)
+ `(scode-quote
,(unsyntax-object environment (scode-quotation-expression quotation))))
(define (unsyntax-variable-object environment object)
(declare (ignore environment))
(scode-variable-name object))
-(define (unsyntax-ACCESS-object environment object)
+(define (unsyntax-access-object environment object)
(or (and (unsyntaxer:elide-global-accesses?)
(unsyntaxer:macroize?)
(let ((access-environment (scode-access-environment object))
'system-global-environment)))
(not (is-bound? name environment))
name)))
- `(ACCESS ,@(unexpand-access environment object))))
+ `(access ,@(unexpand-access environment object))))
(define (unexpand-access environment object)
(let loop ((object object) (separate? #t))
(else #f)))))))
(define (unsyntax-assignment-object environment assignment)
- `(SET! ,(scode-assignment-name assignment)
+ `(set! ,(scode-assignment-name assignment)
,@(unexpand-binding-value environment
(scode-assignment-value assignment))))
'()
`(,(unsyntax-object environment value))))
\f
-(define (unsyntax-COMMENT-object environment comment)
+(define (unsyntax-comment-object environment comment)
(let ((expression
(unsyntax-object environment (scode-comment-expression comment))))
(if (unsyntaxer:show-comments?)
- `(COMMENT ,(scode-comment-text comment) ,expression)
+ `(comment ,(scode-comment-text comment) ,expression)
expression)))
-(define (unsyntax-DECLARATION-object environment declaration)
- `(LOCAL-DECLARE
+(define (unsyntax-declaration-object environment declaration)
+ `(local-declare
,(scode-declaration-text declaration)
,(unsyntax-object environment (scode-declaration-expression declaration))))
(let ((actions (scode-sequence-actions seq)))
(if (and (scode-block-declaration? (car actions))
(pair? (cdr actions)))
- `(BEGIN
- (DECLARE ,@(scode-block-declaration-text (car actions)))
+ `(begin
+ (declare ,@(scode-block-declaration-text (car actions)))
,@(unsyntax-sequence-actions environment (cdr actions)))
- `(BEGIN
+ `(begin
,@(unsyntax-sequence-actions environment actions)))))
(define (unsyntax-sequence-for-splicing environment seq)
(scode-sequence-actions seq))))
(if (eq? #t (unsyntaxer:macroize?))
actions
- `((BEGIN ,@actions))))
+ `((begin ,@actions))))
(list (unsyntax-object environment seq))))
(define (unsyntax-sequence-actions environment actions)
(unscan-defines (scode-open-block-names open-block)
(scode-open-block-declarations open-block)
(scode-open-block-actions open-block)))
- (unsyntax-SEQUENCE-object environment open-block)))
+ (unsyntax-sequence-object environment open-block)))
-(define (unsyntax-DELAY-object environment object)
- `(DELAY ,(unsyntax-object environment (scode-delay-expression object))))
+(define (unsyntax-delay-object environment object)
+ `(delay ,(unsyntax-object environment (scode-delay-expression object))))
-(define (unsyntax-THE-ENVIRONMENT-object environment object)
+(define (unsyntax-the-environment-object environment object)
(declare (ignore environment object))
- `(THE-ENVIRONMENT))
+ `(the-environment))
\f
(define (unsyntax-disjunction-object environment object)
`(or ,@(let ((predicate (scode-disjunction-predicate object))
(define (unsyntax-conditional/default environment
predicate consequent alternative)
- `(IF ,(unsyntax-object environment predicate)
+ `(if ,(unsyntax-object environment predicate)
,(unsyntax-object environment consequent)
,(unsyntax-object environment alternative)))
(define (unsyntax-conditional environment predicate consequent alternative)
(cond ((not alternative)
- `(AND ,@(unexpand-conjunction environment predicate consequent)))
+ `(and ,@(unexpand-conjunction environment predicate consequent)))
((eq? alternative undefined-scode-conditional-branch)
- `(IF ,(unsyntax-object environment predicate)
+ `(if ,(unsyntax-object environment predicate)
,(unsyntax-object environment consequent)))
((eq? consequent undefined-scode-conditional-branch)
- `(IF (,(ucode-primitive not) ,(unsyntax-object environment predicate))
+ `(if (,(ucode-primitive not) ,(unsyntax-object environment predicate))
,(unsyntax-object environment alternative)))
((and (scode-conditional? alternative)
(not (has-substitution? alternative)))
- `(COND ,@(unsyntax-cond-conditional environment predicate
+ `(cond ,@(unsyntax-cond-conditional environment predicate
consequent
alternative)))
(else
((has-substitution? alternative)
=>
(lambda (substitution)
- `((ELSE ,substitution))))
+ `((else ,substitution))))
((scode-disjunction? alternative)
(unsyntax-cond-disjunction
environment
(scode-conditional-consequent alternative)
(scode-conditional-alternative alternative)))
(else
- `((ELSE ,@(unsyntax-sequence-for-splicing environment alternative))))))
+ `((else ,@(unsyntax-sequence-for-splicing environment alternative))))))
(define (unexpand-conjunction environment predicate consequent)
(if (and (scode-conditional? consequent)
\f
;;;; Lambdas
-(define (unsyntax-EXTENDED-LAMBDA-object environment expression)
+(define (unsyntax-extended-lambda-object environment expression)
(if (unsyntaxer:macroize?)
(unsyntax-lambda environment expression)
- `(&XLAMBDA (,(scode-lambda-name expression)
+ `(&xlambda (,(scode-lambda-name expression)
,@(scode-lambda-interface expression))
,(unsyntax-object environment
(lambda-immediate-body expression)))))
-(define (unsyntax-LAMBDA-object environment expression)
+(define (unsyntax-lambda-object environment expression)
(if (unsyntaxer:macroize?)
(unsyntax-lambda environment expression)
(collect-lambda (scode-lambda-name expression)
(define (collect-lambda name bvl body)
(if (eq? name scode-lambda-name:unnamed)
- `(LAMBDA ,bvl ,@body)
- `(NAMED-LAMBDA (,name . ,bvl) ,@body)))
+ `(lambda ,bvl ,@body)
+ `(named-lambda (,name . ,bvl) ,@body)))
(define (unsyntax-lambda-list expression)
(if (not (scode-lambda? expression))
(error:wrong-type-argument expression "SCode lambda"
- 'UNSYNTAX-LAMBDA-LIST))
+ 'unsyntax-lambda-list))
(lambda-components* expression
(lambda (name required optional rest body)
name body
(let ((actions (scode-sequence-actions body)))
(if (and (scode-block-declaration? (car actions))
(pair? (cdr actions)))
- `((DECLARE ,@(scode-block-declaration-text (car actions)))
+ `((declare ,@(scode-block-declaration-text (car actions)))
,@(unsyntax-sequence-for-splicing
environment
(make-scode-sequence (cdr actions))))
(= (length operands) 2)
(scode-delay? (cadr operands))
(not (has-substitution? (cadr operands))))
- `(CONS-STREAM ,(unsyntax-object environment (car operands))
+ `(cons-stream ,(unsyntax-object environment (car operands))
,(unsyntax-object environment
(scode-delay-expression (cadr operands)))))
((scode-lambda? operator)
(= (length required) (length operands)))
(if (or (eq? name scode-lambda-name:unnamed)
(eq? name scode-lambda-name:let))
- `(LET ,(unsyntax-let-bindings environment
+ `(let ,(unsyntax-let-bindings environment
required
operands)
,@(with-bindings environment operator
(let ((expression (car expression)))
(and (list? expression)
(= 4 (length expression))
- (eq? 'LET (car expression))
+ (eq? 'let (car expression))
(eq? '() (cadr expression))
(symbol? (cadddr expression))
(let ((definition (caddr expression)))
(and (pair? definition)
- (eq? 'DEFINE (car definition))
+ (eq? 'define (car definition))
(pair? (cadr definition))
(eq? (caadr definition) (cadddr expression))
(list? (cdadr definition))
(every symbol? (cdadr definition)))))))
- `(LET ,(cadddr (car expression))
+ `(let ,(cadddr (car expression))
,(map (lambda (name value)
`(,name
,@(if (unassigned-reference-trap? value)
(if (or (default-object? transformer) (not transformer))
identity-procedure
(begin
- (guarantee unary-procedure? transformer 'TEMPORARY-FILE-PATHNAME)
+ (guarantee unary-procedure? transformer 'temporary-file-pathname)
transformer))))
(let loop ((ext 0))
(let ((pathname
(define (file-length filename)
(let ((attrs (file-attributes-direct filename)))
(if (not attrs)
- (error:bad-range-argument filename 'FILE-LENGTH))
+ (error:bad-range-argument filename 'file-length))
(file-attributes/length attrs)))
(define (file-modification-time-direct filename)
(define environment-variables)
(define (get-environment-variable name)
- (guarantee string? name 'GET-ENVIRONMENT-VARIABLE)
- (let ((value (hash-table/get environment-variables name 'NONE)))
- (if (eq? value 'NONE)
+ (guarantee string? name 'get-environment-variable)
+ (let ((value (hash-table/get environment-variables name 'none)))
+ (if (eq? value 'none)
(let ((value
((ucode-primitive get-environment-variable 1)
(string-for-primitive name))))
value)))
(define (set-environment-variable! name value)
- (guarantee string? name 'SET-ENVIRONMENT-VARIABLE!)
+ (guarantee string? name 'set-environment-variable!)
(if value
- (guarantee string? value 'SET-ENVIRONMENT-VARIABLE!))
+ (guarantee string? value 'set-environment-variable!))
(hash-table/put! environment-variables name value))
(define (delete-environment-variable! name)
- (guarantee string? name 'DELETE-ENVIRONMENT-VARIABLE!)
+ (guarantee string? name 'delete-environment-variable!)
(hash-table/remove! environment-variables name))
(define (reset-environment-variables!)
(string-ci=? "iso9660" type)
(string-ci=? "ntfs" type)
(string-ci=? "smb" type))
- 'CRLF
- 'LF)))
+ 'crlf
+ 'lf)))
(define (default-line-ending)
- 'LF)
+ 'lf)
(define (copy-file from to)
(let ((input-filename (->namestring (merge-pathnames from)))
(set-file-modes! output-filename (file-modes input-filename))))
(define (init-file-specifier->pathname specifier)
- (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME)
+ (guarantee init-file-specifier? specifier 'init-file-specifier->pathname)
(merge-pathnames (apply string-append
(cons ".mit-scheme"
(append-map (lambda (string) (list "/" string))
(define (partial-uri-state-name puri)
(let ((name (%partial-uri-state-name puri)))
(case name
- ((START-REFERENCE START-ABSOLUTE) 'start)
- ((SCHEME-REFERENCE SCHEME-ABSOLUTE) 'scheme)
- ((SEGMENT-NZ-NC) 'path)
- ((HIER-PART INIT-SLASH)
+ ((start-reference start-absolute) 'start)
+ ((scheme-reference scheme-absolute) 'scheme)
+ ((segment-nz-nc) 'path)
+ ((hier-part init-slash)
(if (partial-uri-scheme puri) 'hier-part 'relative-part))
(else name))))
(segment-nc (push) segment-nz-nc)
(? (set path) query)
(|#| (set path) fragment)
- (EOF))
+ (eof))
(define-ppu-state scheme-reference
(scheme (push) scheme-reference)
(/ (push) path)
(? (set path) query)
(|#| (set path) fragment)
- (EOF))
+ (eof))
(define-ppu-state segment-nz-nc
(segment-nc (push) segment-nz-nc)
(/ (push) path)
(? (set path) query)
(|#| (set path) fragment)
- (EOF (set path)))
+ (eof (set path)))
(define-ppu-state start-absolute
(alpha (push) scheme-absolute)
- (EOF))
+ (eof))
(define-ppu-state scheme-absolute
(scheme (push) scheme-absolute)
(: (set scheme) hier-part)
- (EOF))
+ (eof))
(define-ppu-state hier-part
(segment (push) path)
(/ init-slash)
(? (set path) query)
(|#| (set path) fragment)
- (EOF))
+ (eof))
(define-ppu-state init-slash
(segment (push /) (push) path)
(/ authority)
(? (push /) (set path) query)
(|#| (push /) (set path) fragment)
- (EOF))
+ (eof))
(define-ppu-state authority
(sloppy-auth (push) authority)
(/ (set authority) (push) path)
(? (set authority) query)
(|#| (set authority) fragment)
- (EOF (set authority)))
+ (eof (set authority)))
(define-ppu-state path
(segment (push) path)
(/ (push) path)
(? (set path) query)
(|#| (set path) fragment)
- (EOF (set path)))
+ (eof (set path)))
(define-ppu-state query
(query (push) query)
(|#| (set query) fragment)
- (EOF (set query)))
+ (eof (set query)))
(define-ppu-state fragment
(fragment (push) fragment)
- (EOF (set fragment)))
\ No newline at end of file
+ (eof (set fragment)))
\ No newline at end of file
(type vector)
(named '|#[(runtime reference-trap)reference-trap]|)
(print-procedure
- (simple-unparser-method 'REFERENCE-TRAP
+ (simple-unparser-method 'reference-trap
(lambda (trap)
(list (let ((kind (reference-trap-kind trap)))
(or (reference-trap-kind-name kind)
(define (reference-trap-kind-name kind)
(case kind
- ((0) 'UNASSIGNED)
- ((2) 'UNBOUND)
- ((6) 'EXPENSIVE)
- ((14) 'COMPILER-CACHED)
- ((15) 'MACRO)
+ ((0) 'unassigned)
+ ((2) 'unbound)
+ ((6) 'expensive)
+ ((14) 'compiler-cached)
+ ((15) 'macro)
(else #f)))
(define (make-immediate-reference-trap kind)
(define (cached-reference-trap-value trap)
(if (not (cached-reference-trap? trap))
(error:wrong-type-argument trap "cached reference trap"
- 'CACHED-REFERENCE-TRAP-VALUE))
+ 'cached-reference-trap-value))
(map-reference-trap
(let ((cache (reference-trap-extra trap)))
(lambda ()
(define (macro-reference-trap-transformer trap)
(if (not (macro-reference-trap? trap))
(error:wrong-type-argument trap "macro reference trap"
- 'MACRO-REFERENCE-TRAP-TRANSFORMER))
+ 'macro-reference-trap-transformer))
(reference-trap-extra trap))
(define (make-unmapped-macro-reference-trap transformer)
(define (prompt-for-command-expression prompt #!optional port environment)
(let ((prompt (canonicalize-command-prompt prompt))
- (port (optional-port port 'PROMPT-FOR-COMMAND-EXPRESSION))
+ (port (optional-port port 'prompt-for-command-expression))
(environment
- (optional-environment environment 'PROMPT-FOR-COMMAND-EXPRESSION))
+ (optional-environment environment 'prompt-for-command-expression))
(level (nearest-cmdl/level)))
(let ((operation
- (textual-port-operation port 'PROMPT-FOR-COMMAND-EXPRESSION)))
+ (textual-port-operation port 'prompt-for-command-expression)))
(if operation
(operation port environment prompt level)
(begin
- (guarantee textual-i/o-port? port 'PROMPT-FOR-COMMAND-EXPRESSION)
+ (guarantee textual-i/o-port? port 'prompt-for-command-expression)
(write-command-prompt port prompt level)
- (with-input-port-terminal-mode port 'COOKED
+ (with-input-port-terminal-mode port 'cooked
(lambda ()
(read port environment))))))))
(define (prompt-for-expression prompt #!optional port environment)
(%prompt-for-expression
- (optional-port port 'PROMPT-FOR-EXPRESSION)
- (optional-environment environment 'PROMPT-FOR-EXPRESSION)
+ (optional-port port 'prompt-for-expression)
+ (optional-environment environment 'prompt-for-expression)
prompt
- 'PROMPT-FOR-EXPRESSION))
+ 'prompt-for-expression))
(define (prompt-for-evaluated-expression prompt #!optional environment port)
(let ((environment
- (optional-environment environment 'PROMPT-FOR-EVALUATED-EXPRESSION))
- (port (optional-port port 'PROMPT-FOR-EVALUATED-EXPRESSION)))
+ (optional-environment environment 'prompt-for-evaluated-expression))
+ (port (optional-port port 'prompt-for-evaluated-expression)))
(repl-eval
(%prompt-for-expression port
environment
prompt
- 'PROMPT-FOR-EVALUATED-EXPRESSION)
+ 'prompt-for-evaluated-expression)
environment)))
(define (%prompt-for-expression port environment prompt caller)
(let ((prompt (canonicalize-prompt prompt ": ")))
- (let ((operation (textual-port-operation port 'PROMPT-FOR-EXPRESSION)))
+ (let ((operation (textual-port-operation port 'prompt-for-expression)))
(if operation
(operation port environment prompt)
(begin
(guarantee textual-i/o-port? port caller)
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(fresh-line port)
(newline port)
(write-string prompt port)
(flush-output-port port)))
- (with-input-port-terminal-mode port 'COOKED
+ (with-input-port-terminal-mode port 'cooked
(lambda ()
(read port environment))))))))
(let ((prompt (canonicalize-command-prompt prompt))
(port (if (default-object? port) (interaction-i/o-port) port))
(level (nearest-cmdl/level)))
- (let ((operation (textual-port-operation port 'PROMPT-FOR-COMMAND-CHAR)))
+ (let ((operation (textual-port-operation port 'prompt-for-command-char)))
(if operation
(operation port prompt level)
(default/prompt-for-command-char port prompt level)))))
(write-command-prompt port prompt level)
(let loop ()
(let ((char
- (with-input-port-terminal-mode port 'RAW
+ (with-input-port-terminal-mode port 'raw
(lambda ()
(read-char port)))))
(if (char-graphic? char)
(begin
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(write-char char port)
(flush-output-port port)))
(define (prompt-for-confirmation prompt #!optional port)
(let ((prompt (canonicalize-prompt prompt " (y or n)? "))
(port (if (default-object? port) (interaction-i/o-port) port)))
- (let ((operation (textual-port-operation port 'PROMPT-FOR-CONFIRMATION)))
+ (let ((operation (textual-port-operation port 'prompt-for-confirmation)))
(if operation
(operation port prompt)
(default/prompt-for-confirmation port prompt)))))
(define (default/prompt-for-confirmation port prompt)
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(fresh-line port)))
(let loop ()
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(newline port)
(write-string prompt port)
(flush-output-port port)))
(let ((char
- (with-input-port-terminal-mode port 'RAW
+ (with-input-port-terminal-mode port 'raw
(lambda ()
(read-char port)))))
(case char
((#\y #\Y #\space)
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(write-string "Yes" port)
(flush-output-port port)))
true)
((#\n #\N #\rubout)
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(write-string "No" port)
(flush-output-port port)))
((#\newline)
(loop))
(else
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(write char port)
(beep port)
(define (prompt-for-string prompt #!optional port)
;; Returns a string (the normal, "cooked" input line) or eof-object.
(let ((port (if (default-object? port) (interaction-i/o-port) port)))
- (let ((operation (textual-port-operation port 'PROMPT-FOR-STRING)))
+ (let ((operation (textual-port-operation port 'prompt-for-string)))
(if operation
(operation port prompt)
(default/prompt-for-string port prompt)))))
(define (default/prompt-for-string port prompt)
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(fresh-line port)
(newline port)
(write-string prompt port)
(flush-output-port port)))
- (with-input-port-terminal-mode port 'COOKED
+ (with-input-port-terminal-mode port 'cooked
(lambda ()
(read-line port))))
\f
(cond ((string? prompt)
prompt)
((and (pair? prompt)
- (eq? 'STANDARD (car prompt))
+ (eq? 'standard (car prompt))
(string? (cdr prompt)))
(cons (car prompt) (canonicalize-prompt (cdr prompt) " ")))
(else
(define (write-command-prompt port prompt level)
(if (not (nearest-cmdl/batch-mode?))
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(fresh-line port)
(newline port)
(if (and (pair? prompt)
- (eq? 'STANDARD (car prompt)))
+ (eq? 'standard (car prompt)))
(begin
(write level port)
(write-string " " port)
;;;; Debugger Support
(define (port/debugger-failure port message)
- (let ((operation (textual-port-operation port 'DEBUGGER-FAILURE)))
+ (let ((operation (textual-port-operation port 'debugger-failure)))
(if operation
(operation port message)
(default/debugger-failure port message))))
(default/debugger-message port message))
(define (port/debugger-message port message)
- (let ((operation (textual-port-operation port 'DEBUGGER-MESSAGE)))
+ (let ((operation (textual-port-operation port 'debugger-message)))
(if operation
(operation port message)
(default/debugger-message port message))))
(write-string message port))
(define (port/debugger-presentation port thunk)
- (let ((operation (textual-port-operation port 'DEBUGGER-PRESENTATION)))
+ (let ((operation (textual-port-operation port 'debugger-presentation)))
(if operation
(operation port thunk)
(default/debugger-presentation port thunk))))
(define (port/write-result port expression value hash-number
#!optional environment)
- (let ((operation (textual-port-operation port 'WRITE-RESULT))
+ (let ((operation (textual-port-operation port 'write-result))
(environment
(if (default-object? environment)
(nearest-repl/environment)
- (guarantee environment? environment 'PORT/WRITE-RESULT))))
+ (guarantee environment? environment 'port/write-result))))
(if operation
(operation port expression value hash-number environment)
(default/write-result port expression value hash-number environment))))
(define (default/write-result port expression object hash-number environment)
expression
(if (not (nearest-cmdl/batch-mode?))
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(fresh-line port)
(write-string ";" port)
(define write-result:undefined-value-is-special? true)
(define (port/set-default-directory port directory)
- (let ((operation (textual-port-operation port 'SET-DEFAULT-DIRECTORY)))
+ (let ((operation (textual-port-operation port 'set-default-directory)))
(if operation
(operation port directory))))
(define (port/set-default-environment port environment)
- (let ((operation (textual-port-operation port 'SET-DEFAULT-ENVIRONMENT)))
+ (let ((operation (textual-port-operation port 'set-default-environment)))
(if operation
(operation port environment))))
(define (port/gc-start port)
- (let ((operation (textual-port-operation port 'GC-START)))
+ (let ((operation (textual-port-operation port 'gc-start)))
(if (and operation (not (*within-restore-window?*)))
(operation port))))
(define (port/gc-finish port)
- (let ((operation (textual-port-operation port 'GC-FINISH)))
+ (let ((operation (textual-port-operation port 'gc-finish)))
(if (and operation (not (*within-restore-window?*)))
(operation port))))
(define (port/read-start port)
- (let ((operation (textual-port-operation port 'READ-START)))
+ (let ((operation (textual-port-operation port 'read-start)))
(if operation
(operation port))))
(define (port/read-finish port)
- (let ((operation (textual-port-operation port 'READ-FINISH)))
+ (let ((operation (textual-port-operation port 'read-finish)))
(if operation
(operation port))))
\f
(make-textual-port wrapped-notification-port-type port))
(define (make-wrapped-notification-port-type)
- (make-textual-port-type `((WRITE-CHAR ,operation/write-char)
- (X-SIZE ,operation/x-size)
- (COLUMN ,operation/column)
- (FLUSH-OUTPUT ,operation/flush-output)
- (DISCRETIONARY-FLUSH-OUTPUT
+ (make-textual-port-type `((write-char ,operation/write-char)
+ (x-size ,operation/x-size)
+ (column ,operation/column)
+ (flush-output ,operation/flush-output)
+ (discretionary-flush-output
,operation/discretionary-flush-output))
#f))
(define (operation/x-size port)
(let ((port* (textual-port-state port)))
- (let ((op (textual-port-operation port* 'X-SIZE)))
+ (let ((op (textual-port-operation port* 'x-size)))
(and op
(let ((n (op port*)))
(and n
(define (operation/column port)
(let ((port* (textual-port-state port)))
- (let ((op (textual-port-operation port* 'COLUMN)))
+ (let ((op (textual-port-operation port* 'column)))
(and op
(let ((n (op port*)))
(and n
value))
(define (subvector vector start end)
- (guarantee-subvector vector start end 'SUBVECTOR)
+ (guarantee-subvector vector start end 'subvector)
(let ((result (make-vector (fix:- end start))))
(subvector-move-right! vector start end result 0)
result))
(subvector vector 0 end))
(define (vector-head! vector end)
- (guarantee-subvector vector 0 end 'VECTOR-HEAD!)
+ (guarantee-subvector vector 0 end 'vector-head!)
(if (fix:< end (vector-length vector))
(primitive-object-set! vector 0
(primitive-make-object (ucode-type false)
vector)
(define (vector-tail vector start)
- (guarantee vector? vector 'VECTOR-TAIL)
+ (guarantee vector? vector 'vector-tail)
(subvector vector start (vector-length vector)))
(define (vector-copy vector #!optional start end)
(let ((start (if (default-object? start) 0 start))
(end (if (default-object? end) (vector-length vector) end)))
- (guarantee-subvector vector start end 'VECTOR-COPY)
+ (guarantee-subvector vector start end 'vector-copy)
(let ((result (make-vector (fix:- end start))))
(subvector-move-right! vector start end result 0)
result)))
(let loop ((vectors vectors) (length 0))
(if (pair? vectors)
(begin
- (guarantee vector? (car vectors) 'VECTOR-APPEND)
+ (guarantee vector? (car vectors) 'vector-append)
(loop (cdr vectors)
(fix:+ (vector-length (car vectors)) length)))
length)))))
result))))
(define (vector-grow vector length #!optional value)
- (guarantee vector? vector 'VECTOR-GROW)
+ (guarantee vector? vector 'vector-grow)
(if (not (index-fixnum? length))
- (error:wrong-type-argument length "vector length" 'VECTOR-GROW))
+ (error:wrong-type-argument length "vector length" 'vector-grow))
(if (fix:< length (vector-length vector))
- (error:bad-range-argument length 'VECTOR-GROW))
+ (error:bad-range-argument length 'vector-grow))
(let ((vector* (make-vector length value)))
(subvector-move-right! vector 0 (vector-length vector) vector* 0)
vector*))
vector))
(define (vector-map procedure vector . vectors)
- (guarantee vector? vector 'VECTOR-MAP)
- (for-each (lambda (v) (guarantee vector? v 'VECTOR-MAP)) vectors)
+ (guarantee vector? vector 'vector-map)
+ (for-each (lambda (v) (guarantee vector? v 'vector-map)) vectors)
(let ((n (vector-length vector)))
(for-each (lambda (v)
(if (not (fix:= (vector-length v) n))
- (error:bad-range-argument v 'VECTOR-MAP)))
+ (error:bad-range-argument v 'vector-map)))
vectors)
(let ((result (make-vector n)))
(do ((i 0 (fix:+ i 1)))
result)))
(define (vector-for-each procedure vector . vectors)
- (guarantee vector? vector 'VECTOR-FOR-EACH)
- (for-each (lambda (v) (guarantee vector? v 'VECTOR-FOR-EACH)) vectors)
+ (guarantee vector? vector 'vector-for-each)
+ (for-each (lambda (v) (guarantee vector? v 'vector-for-each)) vectors)
(let ((n (vector-length vector)))
(for-each (lambda (v)
(if (not (fix:= (vector-length v) n))
- (error:bad-range-argument v 'VECTOR-FOR-EACH)))
+ (error:bad-range-argument v 'vector-for-each)))
vectors)
(do ((i 0 (fix:+ i 1)))
((not (fix:< i n)) unspecific)
(vector-for-each procedure vector))
\f
(define (subvector-find-next-element vector start end item)
- (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT)
+ (guarantee-subvector vector start end 'subvector-find-next-element)
(let loop ((index start))
(and (fix:< index end)
(if (eqv? (vector-ref vector index) item)
(loop (fix:+ index 1))))))
(define (subvector-find-next-element-not vector start end item)
- (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT-NOT)
+ (guarantee-subvector vector start end 'subvector-find-next-element-not)
(let loop ((index start))
(and (fix:< index end)
(if (eqv? (vector-ref vector index) item)
index))))
(define (subvector-find-previous-element vector start end item)
- (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT)
+ (guarantee-subvector vector start end 'subvector-find-previous-element)
(let loop ((index (fix:- end 1)))
(and (fix:<= start index)
(if (eqv? (vector-ref vector index) item)
(loop (fix:- index 1))))))
(define (subvector-find-previous-element-not vector start end item)
- (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT-NOT)
+ (guarantee-subvector vector start end 'subvector-find-previous-element-not)
(let loop ((index (fix:- end 1)))
(and (fix:<= start index)
(if (eqv? (vector-ref vector index) item)
index))))
(define-integrable (vector-find-next-element vector item)
- (guarantee vector? vector 'VECTOR-FIND-NEXT-ELEMENT)
+ (guarantee vector? vector 'vector-find-next-element)
(subvector-find-next-element vector 0 (vector-length vector) item))
(define-integrable (vector-find-previous-element vector item)
- (guarantee vector? vector 'VECTOR-FIND-PREVIOUS-ELEMENT)
+ (guarantee vector? vector 'vector-find-previous-element)
(subvector-find-previous-element vector 0 (vector-length vector) item))
(define (vector-binary-search vector key<? unwrap-key key)
- (guarantee vector? vector 'VECTOR-BINARY-SEARCH)
+ (guarantee vector? vector 'vector-binary-search)
(let loop ((start 0) (end (vector-length vector)))
(and (fix:< start end)
(let ((midpoint (fix:quotient (fix:+ start end) 2)))
((key<? key* key) (loop (fix:+ midpoint 1) end))
(else item))))))))
-(let-syntax
- ((iref
- (sc-macro-transformer
- (lambda (form environment)
- `(DEFINE-INTEGRABLE (,(cadr form) VECTOR)
- (GUARANTEE VECTOR? VECTOR ',(cadr form))
- (VECTOR-REF VECTOR ,(caddr form)))))))
- (iref vector-first 0)
- (iref vector-second 1)
- (iref vector-third 2)
- (iref vector-fourth 3)
- (iref vector-fifth 4)
- (iref vector-sixth 5)
- (iref vector-seventh 6)
- (iref vector-eighth 7))
+(define-integrable (vector-first vector) (vector-ref vector 0))
+(define-integrable (vector-second vector) (vector-ref vector 1))
+(define-integrable (vector-third vector) (vector-ref vector 2))
+(define-integrable (vector-fourth vector) (vector-ref vector 3))
+(define-integrable (vector-fifth vector) (vector-ref vector 4))
+(define-integrable (vector-sixth vector) (vector-ref vector 5))
+(define-integrable (vector-seventh vector) (vector-ref vector 6))
+(define-integrable (vector-eighth vector) (vector-ref vector 7))
\f
(define (vector-move! v1 v2)
(vector-copy! v2 0 v1))
(subvector-move-right! from start end to at)))))
(define (subvector-filled? vector start end element)
- (guarantee-subvector vector start end 'SUBVECTOR-FILLED?)
+ (guarantee-subvector vector start end 'subvector-filled?)
(let loop ((index start))
(or (fix:= index end)
(and (eqv? (vector-ref vector index) element)
(loop (fix:+ index 1))))))
(define (vector-filled? vector element)
- (guarantee vector? vector 'VECTOR-FILLED?)
+ (guarantee vector? vector 'vector-filled?)
(subvector-filled? vector 0 (vector-length vector) element))
(define (subvector-uniform? vector start end)
- (guarantee-subvector vector start end 'SUBVECTOR-UNIFORM?)
+ (guarantee-subvector vector start end 'subvector-uniform?)
(if (fix:< start end)
(subvector-filled? vector (fix:+ start 1) end (vector-ref vector start))
#t))
(define (vector-uniform? vector)
- (guarantee vector? vector 'VECTOR-UNIFORM?)
+ (guarantee vector? vector 'vector-uniform?)
(subvector-uniform? vector 0 (vector-length vector)))
(define (vector-of-type? object predicate)
(let ((port
(if (default-object? port)
(current-output-port)
- (guarantee textual-output-port? port 'WRITE-MIT-SCHEME-COPYRIGHT)))
+ (guarantee textual-output-port? port 'write-mit-scheme-copyright)))
(cmark (if (default-object? cmark) "(C)" cmark))
(line-prefix (if (default-object? line-prefix) "" line-prefix)))
(write-words (let ((years (map number->string copyright-years)))
(let ((port
(if (default-object? port)
(current-output-port)
- (guarantee textual-output-port? port 'WRITE-MIT-SCHEME-LICENSE)))
+ (guarantee textual-output-port? port 'write-mit-scheme-license)))
(line-prefix (if (default-object? line-prefix) "" line-prefix))
(short? (if (default-object? short?) #f short?)))
(let loop
(declare (usual-integrations))
\f
(define (where #!optional environment)
- (with-simple-restart 'CONTINUE "Return from WHERE."
+ (with-simple-restart 'continue "Return from WHERE."
(lambda ()
(let ((wstate
(make-wstate
(set!
command-set
(make-command-set
- 'WHERE-COMMANDS
+ 'where-commands
`((#\? ,standard-help-command
"help, list command letters")
(#\A ,show-all
(let ((parent (loop prefix)))
(and parent
(get-subkey parent name
- (eq? 'CREATE-IF-NEEDED mode))))
- (get-root-key name 'WIN32-REGISTRY/OPEN-KEY))))))
- (if (and (not key) (eq? 'MUST-EXIST mode))
+ (eq? 'create-if-needed mode))))
+ (get-root-key name 'win32-registry/open-key))))))
+ (if (and (not key) (eq? 'must-exist mode))
(error "Unable to open registry key:" name))
key))
key))))
(define (win32-registry/add-subkey parent name)
- (guarantee-registry-key parent 'WIN32-REGISTRY/ADD-SUBKEY)
+ (guarantee-registry-key parent 'win32-registry/add-subkey)
(get-subkey parent name #t))
(define (win32-registry/delete-subkey parent name)
- (guarantee-registry-key parent 'WIN32-REGISTRY/DELETE-SUBKEY)
+ (guarantee-registry-key parent 'win32-registry/delete-subkey)
(win32-delete-registry-key (guarantee-handle parent) name)
(delete-subkey! parent name))
(define (win32-registry/key-name key)
- (guarantee-registry-key key 'WIN32-REGISTRY/KEY-NAME)
+ (guarantee-registry-key key 'win32-registry/key-name)
(registry-key-name key))
(define (win32-registry/key-full-name key)
- (guarantee-registry-key key 'WIN32-REGISTRY/KEY-FULL-NAME)
+ (guarantee-registry-key key 'win32-registry/key-full-name)
(if (registry-key-parent key)
(string-append (win32-registry/key-name (registry-key-parent key))
"\\"
(registry-key-name key)))
(define (win32-registry/key-parent key)
- (guarantee-registry-key key 'WIN32-REGISTRY/KEY-PARENT)
+ (guarantee-registry-key key 'win32-registry/key-parent)
(registry-key-parent key))
(define (win32-registry/subkeys key)
- (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEYS)
+ (guarantee-registry-key key 'win32-registry/subkeys)
(guarantee-subkeys key)
(map (lambda (k.n) (guarantee-subkey key k.n))
(registry-key-subkeys key)))
(define (win32-registry/subkey key name)
- (guarantee-registry-key key 'WIN32-REGISTRY/SUBKEY)
+ (guarantee-registry-key key 'win32-registry/subkey)
(find-subkey key name))
\f
(define (win32-registry/value-names key)
- (guarantee-registry-key key 'WIN32-REGISTRY/VALUE-NAMES)
+ (guarantee-registry-key key 'win32-registry/value-names)
(guarantee-values key)
(map registry-value-name (registry-key-values key)))
(define (win32-registry/get-value key name)
- (guarantee-registry-key key 'WIN32-REGISTRY/GET-VALUE)
+ (guarantee-registry-key key 'win32-registry/get-value)
(let ((data (win32-query-registry-value (guarantee-handle key) name)))
(if data
(values (number->value-type (car data)) (cdr data))
(values #f #f))))
(define (win32-registry/set-value key name type data)
- (guarantee-registry-key key 'WIN32-REGISTRY/SET-VALUE)
+ (guarantee-registry-key key 'win32-registry/set-value)
(win32-set-registry-value (guarantee-handle key) name
(value-type->number type) data)
(add-value! key name type))
(define (win32-registry/delete-value key name)
- (guarantee-registry-key key 'WIN32-REGISTRY/DELETE-VALUE)
+ (guarantee-registry-key key 'win32-registry/delete-value)
(win32-delete-registry-value (guarantee-handle key) name)
(delete-value! key name))
(constructor %make-registry-key (parent name handle))
(predicate win32-registry/key?)
(print-procedure
- (simple-unparser-method 'REGISTRY-KEY
+ (simple-unparser-method 'registry-key
(lambda (key)
(list (registry-key-name key))))))
(name #f read-only #t)
(parent #f read-only #t)
(handle #f)
- (subkeys 'UNKNOWN)
- (values 'UNKNOWN))
+ (subkeys 'unknown)
+ (values 'unknown))
(define (guarantee-registry-key object procedure)
(if (not (win32-registry/key? object))
(error:wrong-type-argument object "registry key" procedure)))
(define (guarantee-handle key)
- (if (eq? 'DELETED (registry-key-handle key))
+ (if (eq? 'deleted (registry-key-handle key))
(error "Registry key has been deleted:" key))
(or (registry-key-handle key)
(begin
(define-structure (registry-value
(print-procedure
- (simple-unparser-method 'REGISTRY-VALUE
+ (simple-unparser-method 'registry-value
(lambda (key)
(list (registry-value-name key))))))
(name #f read-only #t)
#f)))
(define (guarantee-subkeys key)
- (if (eq? 'UNKNOWN (registry-key-subkeys key))
+ (if (eq? 'unknown (registry-key-subkeys key))
(set-registry-key-subkeys! key
(map (lambda (key)
(%weak-cons key
key)))
(define (add-subkey! parent name key)
- (if (not (eq? 'UNKNOWN (registry-key-subkeys parent)))
+ (if (not (eq? 'unknown (registry-key-subkeys parent)))
(let loop ((subkeys (registry-key-subkeys parent)))
(if (pair? subkeys)
(if (not (string-ci=? name (%weak-cdr (car subkeys))))
(cons (%weak-cons key name) (registry-key-subkeys parent)))))))
(define (delete-subkey! parent name)
- (if (not (eq? 'UNKNOWN (registry-key-subkeys parent)))
+ (if (not (eq? 'unknown (registry-key-subkeys parent)))
(let loop ((subkeys (registry-key-subkeys parent)) (prev #f))
(if (pair? subkeys)
(if (string-ci=? name (%weak-cdr (car subkeys)))
(if key
(begin
(close-registry-handle key)
- (set-registry-key-handle! key 'DELETED))))
+ (set-registry-key-handle! key 'deleted))))
(if prev
(set-cdr! prev (cdr subkeys))
(set-registry-key-subkeys! parent (cdr subkeys)))))
;;;; Value Manipulation
(define (guarantee-values key)
- (if (eq? 'UNKNOWN (registry-key-values key))
+ (if (eq? 'unknown (registry-key-values key))
(set-registry-key-values! key (generate-values key))))
(define (generate-values key)
#f)))
(define (add-value! key name type)
- (if (not (eq? 'UNKNOWN (registry-key-values key)))
+ (if (not (eq? 'unknown (registry-key-values key)))
(let loop ((vs (registry-key-values key)))
(if (pair? vs)
(if (string-ci=? name (registry-value-name (car vs)))
(registry-key-values key)))))))
(define (delete-value! key name)
- (if (not (eq? 'UNKNOWN (registry-key-values key)))
+ (if (not (eq? 'unknown (registry-key-values key)))
(let loop ((vs (registry-key-values key)) (prev #f))
(if (pair? vs)
(if (string-ci=? name (registry-value-name (car vs)))
(map (lambda (n.h)
(%make-registry-key #f (car n.h) (cdr n.h)))
(win32-predefined-registry-keys)))
- (set! open-handles-list (list 'OPEN-HANDLES-LIST))
+ (set! open-handles-list (list 'open-handles-list))
(add-gc-daemon! close-lost-open-keys-daemon))
(define (close-lost-open-keys-daemon)
;;; Value types:
(define value-types
- '#((REG_NONE) ; No value type
- (REG_SZ) ; Unicode null-terminated string
- (REG_EXPAND_SZ) ; Unicode null-terminated
+ '#((reg_none) ; No value type
+ (reg_sz) ; Unicode null-terminated string
+ (reg_expand_sz) ; Unicode null-terminated
; string (with environment
; variable references)
- (REG_BINARY) ; Free form binary
- (REG_DWORD REG_DWORD_LITTLE_ENDIAN) ; 32-bit number
- (REG_DWORD_BIG_ENDIAN) ; 32-bit number
- (REG_LINK) ; Symbolic Link (unicode)
- (REG_MULTI_SZ) ; Multiple Unicode strings
- (REG_RESOURCE_LIST) ; Resource list in the resource map
- (REG_FULL_RESOURCE_DESCRIPTOR) ; Resource list in the
+ (reg_binary) ; Free form binary
+ (reg_dword reg_dword_little_endian) ; 32-bit number
+ (reg_dword_big_endian) ; 32-bit number
+ (reg_link) ; Symbolic Link (unicode)
+ (reg_multi_sz) ; Multiple Unicode strings
+ (reg_resource_list) ; Resource list in the resource map
+ (reg_full_resource_descriptor) ; Resource list in the
; hardware description
- (REG_RESOURCE_REQUIREMENTS_LIST)
+ (reg_resource_requirements_list)
))
(define (number->value-type n)
(set-state-point/from-nearer! new-root #f)
(set-state-space/nearest-point! space new-root)
(with-stack-marker from-nearer
- 'SET-INTERRUPT-ENABLES! interrupt-mask))
+ 'set-interrupt-enables! interrupt-mask))
;; Disable interrupts again in case FROM-NEARER
;; re-enabled them.
((ucode-primitive set-interrupt-enables! 1) interrupt-mask)
(procedure (fix:and interrupt-mask interrupt-mask/gc-ok)))))
\f
(define (current-state-point space)
- (guarantee-state-space space 'CURRENT-STATE-POINT)
+ (guarantee-state-space space 'current-state-point)
(state-space/nearest-point space))
(define (execute-at-new-state-point space before during after)
- (guarantee-state-space space 'EXECUTE-AT-NEW-STATE-POINT)
+ (guarantee-state-space space 'execute-at-new-state-point)
(%execute-at-new-state-point space before during after))
(define (translate-to-state-point point)
- (guarantee-state-point point 'TRANSLATE-TO-STATE-POINT)
+ (guarantee-state-point point 'translate-to-state-point)
(%translate-to-state-point point))
(define (state-point/space point)
- (guarantee-state-point point 'STATE-POINT/SPACE)
+ (guarantee-state-point point 'state-point/space)
(let ((interrupt-mask (limit-interrupts! interrupt-mask/gc-ok)))
(let loop ((point point))
(let ((nearer-point (state-point/nearer-point point)))
(define (set-dynamic-state! state global-only?)
(if (not (dynamic-state? state))
- (error:wrong-type-argument state "dynamic state" 'SET-DYNAMIC-STATE!))
+ (error:wrong-type-argument state "dynamic state" 'set-dynamic-state!))
(if (not global-only?)
(%translate-to-state-point (dynamic-state/local state)))
(%translate-to-state-point (dynamic-state/global state)))
(let ((port
(if (default-object? port)
(current-output-port)
- (guarantee textual-output-port? port 'WORLD-REPORT)))
+ (guarantee textual-output-port? port 'world-report)))
(flags (cons (cons (console-thread) "console")
(if (default-object? thread-flags)
'()
(define (write-state thread port)
(write-string (case (thread-execution-state thread)
- ((RUNNING) "running")
- ((DEAD) " dead ")
- ((WAITING) "waiting")
- ((STOPPED) "stopped")
- ((RUNNING-WITHOUT-PREEMPTION) "RUNNING")
+ ((running) "running")
+ ((dead) " dead ")
+ ((waiting) "waiting")
+ ((stopped) "stopped")
+ ((running-without-preemption) "RUNNING")
(else " ????"))
port))
(directory-pathname-as-file pathname))
"not a directory"
"no such directory")
- 'SET-WORKING-DIRECTORY-PATHNAME!
+ 'set-working-directory-pathname!
(list name)))
(working-directory-pathname pathname)
(cmdl/set-default-directory (nearest-cmdl) pathname)
(define (initialize-package!)
(set! x-graphics-device-type
(make-graphics-device-type
- 'X
+ 'x
`((available? ,x-graphics/available?)
(clear ,x-graphics/clear)
(close ,x-graphics/close-window)
(conc-name x-display/)
(constructor make-x-display (name xd))
(print-procedure
- (simple-unparser-method 'X-DISPLAY
+ (simple-unparser-method 'x-display
(lambda (display)
(list (x-display/name display))))))
(name #f read-only #t)
(set! registration
(permanently-register-io-thread-event
(x-display-descriptor (x-display/xd display))
- 'READ
+ 'read
(current-thread)
(lambda (mode)
mode
(define (%read-and-process-event display)
(let ((event
(or (x-display-process-events (x-display/xd display) 2)
- (and (eq? 'READ
+ (and (eq? 'read
(test-for-io-on-descriptor
(x-display-descriptor (x-display/xd display))
#t
- 'READ))
+ 'read))
(x-display-process-events (x-display/xd display) 1)))))
(if (and event (not (eq? #t event)))
(process-event display event))))
(x-graphics-reconfigure (vector-ref event 1)
(vector-ref event 2)
(vector-ref event 3))
- (if (eq? 'NEVER (x-window/mapped? window))
+ (if (eq? 'never (x-window/mapped? window))
(set-x-window/mapped?! window #t))))
(define-event-handler event-type:delete-window
(define-event-handler event-type:visibility
(lambda (window event)
(case (vector-ref event 2)
- ((0) (set-x-window/visibility! window 'UNOBSCURED))
- ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED))
- ((2) (set-x-window/visibility! window 'OBSCURED)))))
+ ((0) (set-x-window/visibility! window 'unobscured))
+ ((1) (set-x-window/visibility! window 'partially-obscured))
+ ((2) (set-x-window/visibility! window 'obscured)))))
(let ((mouse-event-handler
(lambda (window event)
(constructor make-x-window (xw display)))
xw
(display #f read-only #t)
- (mapped? 'NEVER)
+ (mapped? 'never)
(visibility #f)
(user-event-mask user-event-mask:default))
(lambda ()
(decode-suppress-map-arg (and (not (default-object? suppress-map?))
suppress-map?)
- 'MAKE-GRAPHICS-DEVICE))
+ 'make-graphics-device))
(lambda (map? resource class)
(let ((xw
(x-graphics-open-window
(define (x-graphics/flush device)
(if (and x-graphics:auto-raise?
(x-graphics-device/mapped? device)
- (not (eq? 'UNOBSCURED (x-graphics-device/visibility device))))
+ (not (eq? 'unobscured (x-graphics-device/visibility device))))
(x-graphics/raise-window device))
((ucode-primitive x-display-flush 1) (x-graphics-device/xd device)))
(define (x-graphics/set-line-style device line-style)
(if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
(error:wrong-type-argument line-style "graphics line style"
- 'SET-LINE-STYLE))
+ 'set-line-style))
(let ((xw (x-graphics-device/xw device)))
(if (zero? line-style)
(x-graphics-set-line-style xw 0)
(define (initialize-image-datatype)
(1d-table/put!
(graphics-type-properties x-graphics-device-type)
- 'IMAGE-TYPE
+ 'image-type
(make-image-type
`((create ,create-x-image)
(destroy ,x-graphics-image/destroy)
(set! rewrite-walker
(make-scode-walker
rewrite/constant
- `((ACCESS ,rewrite/access)
- (ASSIGNMENT ,rewrite/assignment)
- (COMBINATION ,rewrite/combination)
- (COMMENT ,rewrite/comment)
- (CONDITIONAL ,rewrite/conditional)
- (DELAY ,rewrite/delay)
- (DISJUNCTION ,rewrite/disjunction)
- (LAMBDA ,rewrite/lambda)
- (SEQUENCE ,rewrite/sequence)
- (THE-ENVIRONMENT ,rewrite/the-environment)
- (UNASSIGNED? ,rewrite/unassigned?)
- (VARIABLE ,rewrite/variable))))
+ `((access ,rewrite/access)
+ (assignment ,rewrite/assignment)
+ (combination ,rewrite/combination)
+ (comment ,rewrite/comment)
+ (conditional ,rewrite/conditional)
+ (delay ,rewrite/delay)
+ (disjunction ,rewrite/disjunction)
+ (lambda ,rewrite/lambda)
+ (sequence ,rewrite/sequence)
+ (the-environment ,rewrite/the-environment)
+ (unassigned? ,rewrite/unassigned?)
+ (variable ,rewrite/variable))))
(set! hook/extended-scode-eval default/extended-scode-eval)
unspecific)
\f
(define (step-form expression environment)
;; start a new evaluation
- (step-start (make-ynode #f 'TOP ynode-exp:top-level)
+ (step-start (make-ynode #f 'top ynode-exp:top-level)
(lambda () (eval expression environment))
(if (stepper-compiled?) 0 6)
(if (stepper-compiled?) 1 5)))
(define (step-proceed)
;; proceed from breakpoint
- (step-start (make-ynode #f 'PROCEED ynode-exp:proceed)
+ (step-start (make-ynode #f 'proceed ynode-exp:proceed)
(lambda () (continue))
(if (stepper-compiled?) 0 4)
(if (stepper-compiled?) 5 7)))
(step-over-1 state))
(define (step-until-visibly state)
- (set-stepper-step-until?! state 'ANIMATE)
+ (set-stepper-step-until?! state 'animate)
(step-over-1 state))
(define (step-over-1 state)
- (if (not (eq? (car (stepper-last-event state)) 'CALL))
+ (if (not (eq? (car (stepper-last-event state)) 'call))
(error "Last event was not a call:" (stepper-last-event state)))
(set-stepper-step-over! state (stack-top state))
(new-ynode-type! (stack-top state)
- (if (stepper-step-until? state) 'EVAL 'STEP-OVER))
+ (if (stepper-step-until? state) 'eval 'step-over))
(raw-step state))
(define (raw-step state)
(hunk3-cons
(lambda (expr env)
(hook-record state
- (list 'EVAL (map-reference-trap (lambda () expr)) env))
+ (list 'eval (map-reference-trap (lambda () expr)) env))
(process-eval state (map-reference-trap (lambda () expr)))
(primitive-eval-step expr env hooks))
(lambda (proc . args)
(hook-record state
- (list 'APPLY
+ (list 'apply
proc
(map (lambda (arg)
(map-reference-trap (lambda () arg)))
(primitive-apply-step proc args hooks))
(lambda (value)
(hook-record state
- (list 'RETURN (map-reference-trap (lambda () value))))
+ (list 'return (map-reference-trap (lambda () value))))
(process-return state (map-reference-trap (lambda () value)))
(primitive-return-step value hooks)))))
hooks))
((system-hunk3-cxr0 (stepper-hooks state)) expr env)
(begin
(set! skip-evals (- skip-evals 1))
- (hook-record state (list 'EVAL expr env))
+ (hook-record state (list 'eval expr env))
(primitive-eval-step expr env hooks))))
#f
(lambda (result)
((system-hunk3-cxr2 (stepper-hooks state)) result)
(begin
(set! skip-returns (- skip-returns 1))
- (hook-record state (list 'RESULT result))
+ (hook-record state (list 'result result))
(primitive-return-step result hooks)))))))
hooks))
(stack-top state))
(if (and (stepper-step-over state)
(not (stepper-step-until? state)))
- 'STEPPED-OVER
- 'EVAL)
+ 'stepped-over
+ 'eval)
exp)))
(stack-push! state node)
- (set-stepper-last-event! state `(CALL ,node))
+ (set-stepper-last-event! state `(call ,node))
(maybe-redisplay state)))
(define (process-apply state proc)
(maybe-end-step-over state))
(let ((node
(let ((node (stack-top state)))
- (if (eq? (ynode-type node) 'PROCEED)
+ (if (eq? (ynode-type node) 'proceed)
(ynode-splice-under node)
(begin
(stack-pop! state)
(new-ynode-result! node result)
(if (stack-empty? state)
(set-stepper-finished! state node))
- (set-stepper-last-event! state `(RETURN ,node))
+ (set-stepper-last-event! state `(return ,node))
(maybe-redisplay state)))
(define (maybe-redisplay state)
(if (stepper-step-over state)
- (if (eq? (stepper-step-until? state) 'ANIMATE)
+ (if (eq? (stepper-step-until? state) 'animate)
(step-output state #t))
(call-with-current-continuation
(lambda (k)
(result #f)
(redisplay-flags #f read-only #t))
-(define ynode-exp:top-level (list 'STEPPER-TOP-LEVEL))
-(define ynode-exp:proceed (list 'STEPPER-PROCEED))
+(define ynode-exp:top-level (list 'stepper-top-level))
+(define ynode-exp:proceed (list 'stepper-proceed))
(define (ynode-exp-special node)
(let ((exp (ynode-exp node)))
(eq? ynode-exp:proceed exp))
(car exp))))
-(define ynode-result:waiting (list 'WAITING))
-(define ynode-result:reduced (list 'REDUCED))
-(define ynode-result:unknown (list 'UNKNOWN))
+(define ynode-result:waiting (list 'waiting))
+(define ynode-result:reduced (list 'reduced))
+(define ynode-result:unknown (list 'unknown))
(define (ynode-result-special node)
(let ((result (ynode-result node)))
(define (ynode-splice-under node)
(let ((children (ynode-children node)))
(set-ynode-children! node '())
- (let ((new-node (make-ynode node 'EVAL ynode-result:unknown)))
+ (let ((new-node (make-ynode node 'eval ynode-result:unknown)))
(set-ynode-children! new-node children)
(for-each (lambda (c) (set-ynode-parent! c new-node)) children)
(let loop ((node new-node))
(define (ynode-hidden-children? node)
;; used to control drawing of arrow
- (and (eq? (ynode-type node) 'STEP-OVER)
+ (and (eq? (ynode-type node) 'step-over)
(not (null? (ynode-children node)))))
(define (ynode-needs-redisplay! ynode)
(ynode-needs-redisplay! ynode))
(define (ynode-expand! node)
- (new-ynode-type! node 'EVAL)
+ (new-ynode-type! node 'eval)
(for-each (lambda (dependent)
- (if (eq? (ynode-type dependent) 'STEPPED-OVER)
- (new-ynode-type! dependent 'STEP-OVER)))
+ (if (eq? (ynode-type dependent) 'stepped-over)
+ (new-ynode-type! dependent 'step-over)))
(ynode-dependents node)))
(define (ynode-contract! node)
- (new-ynode-type! node 'STEP-OVER)
+ (new-ynode-type! node 'step-over)
(for-each (lambda (dependent)
- (new-ynode-type! dependent 'STEPPED-OVER))
+ (new-ynode-type! dependent 'stepped-over))
(ynode-reductions node)))
\f
;;;; Miscellaneous
projects / mit-scheme.git / commitdiff