this-element)))
(define (make-list length #!optional value)
- (guarantee index-fixnum? length 'MAKE-LIST)
+ (guarantee index-fixnum? length 'make-list)
(let ((value (if (default-object? value) '() value)))
(let loop ((n length) (result '()))
(if (fix:zero? n)
items)
(define (make-circular-list length #!optional value)
- (guarantee index-fixnum? length 'MAKE-CIRCULAR-LIST)
+ (guarantee index-fixnum? length 'make-circular-list)
(if (fix:> length 0)
(let ((value (if (default-object? value) '() value)))
(let ((last (cons value '())))
'()))
(define (make-initialized-list length initialization)
- (guarantee index-fixnum? length 'MAKE-INITIALIZED-LIST)
+ (guarantee index-fixnum? length 'make-initialized-list)
(let loop ((index (fix:- length 1)) (result '()))
(if (fix:< index 0)
result
(cons a d))
\f
(define (iota count #!optional start step)
- (guarantee index-fixnum? count 'IOTA)
+ (guarantee index-fixnum? count 'iota)
(let ((start
(if (default-object? start)
0
(begin
- (guarantee number? start 'IOTA)
+ (guarantee number? start 'iota)
start)))
(step
(if (default-object? step)
1
(begin
- (guarantee number? step 'IOTA)
+ (guarantee number? step 'iota)
step))))
(make-initialized-list count (lambda (index) (+ start (* index step))))))
n))
\f
(define (length list)
- (guarantee-list->length list 'LENGTH))
+ (guarantee-list->length list 'length))
(define (length=? left right)
(define (%length=? n list)
(define (lose)
(for-each (lambda (list)
- (guarantee list? list 'LIST=))
+ (guarantee list? list 'list=))
lists))
(if (and (pair? lists)
(define (list-ref list index)
(let ((tail (list-tail list index)))
(if (not (pair? tail))
- (error:bad-range-argument index 'LIST-REF))
+ (error:bad-range-argument index 'list-ref))
(car tail)))
(define (list-set! list index new-value)
(let ((tail (list-tail list index)))
(if (not (pair? tail))
- (error:bad-range-argument index 'LIST-SET!))
+ (error:bad-range-argument index 'list-set!))
(set-car! tail new-value)))
(define (list-tail list index)
- (guarantee index-fixnum? index 'LIST-TAIL)
+ (guarantee index-fixnum? index 'list-tail)
(let loop ((list list) (index* index))
(if (fix:zero? index*)
list
(begin
(if (not (pair? list))
- (error:bad-range-argument index 'LIST-TAIL))
+ (error:bad-range-argument index 'list-tail))
(loop (cdr list) (fix:- index* 1))))))
(define (list-head list index)
- (guarantee index-fixnum? index 'LIST-HEAD)
+ (guarantee index-fixnum? index 'list-head)
(let loop ((list list) (index* index))
(if (fix:zero? index*)
'()
(begin
(if (not (pair? list))
- (error:bad-range-argument index 'LIST-HEAD))
+ (error:bad-range-argument index 'list-head))
(cons (car list) (loop (cdr list) (fix:- index* 1)))))))
(define (sublist list start end)
(list-head (list-tail list start) (- end start)))
(define (list-copy items)
- (let ((lose (lambda () (error:not-a list? items 'LIST-COPY))))
+ (let ((lose (lambda () (error:not-a list? items 'list-copy))))
(cond ((pair? items)
(let ((head (cons (car items) '())))
(let loop ((list (cdr items)) (previous head))
(do ((code operation-list (cdr code))
(answer 1 (+ (* answer 2)
(case (car code)
- ((CAR) 1)
- ((CDR) 0)
+ ((car) 1)
+ ((cdr) 0)
(else (error "encode-general-car-cdr: Invalid operation"
(car code)))))))
((not (pair? code))
(declare (integrate-operator safe-car safe-cdr))
(define (safe-car x)
- (if (pair? x) (car x) (error:not-a pair? x 'SAFE-CAR)))
+ (if (pair? x) (car x) (error:not-a pair? x 'safe-car)))
(define (safe-cdr x)
- (if (pair? x) (cdr x) (error:not-a pair? x 'SAFE-CDR)))
+ (if (pair? x) (cdr x) (error:not-a pair? x 'safe-cdr)))
(define (caar x) (safe-car (safe-car x)))
(define (cadr x) (safe-car (safe-cdr x)))
(set-cdr! cell accum))
(else
(error:not-a list? (car rest)
- 'APPEND))))
+ 'append))))
root))
((null? l1)
accum)
(else
- (error:not-a list? (car rest) 'APPEND))))
+ (error:not-a list? (car rest) 'append))))
(cdr rest))
accum))
'())))
head)
(else
(if (not (null? head))
- (error:not-a list? (car lists) 'APPEND!))
+ (error:not-a list? (car lists) 'append!))
(loop (car tail) (cdr tail)))))
'()))
(loop (cdr rest) (cons (car rest) so-far))
(begin
(if (not (null? rest))
- (error:not-a list? l 'REVERSE*))
+ (error:not-a list? l 'reverse*))
so-far))))
(define (reverse*! l tail)
(loop next current))
(begin
(if (not (null? current))
- (error:not-a list? l 'REVERSE*!))
+ (error:not-a list? l 'reverse*!))
new-cdr))))
\f
;;;; Mapping Procedures
(cdr head)))
(define (bad-end)
- (mapper-error (cons first rest) 'MAP))
+ (mapper-error (cons first rest) 'map))
(if (pair? rest)
(if (pair? (cdr rest))
(extra-vars (list-ref form 2))
(combiner (list-ref form 3))
(initial-value (list-ref form 4)))
- `(SET! ,name
- (NAMED-LAMBDA (,name ,@extra-vars PROCEDURE FIRST . REST)
-
- (DEFINE (MAP-1 L)
- (IF (PAIR? L)
- (,combiner (PROCEDURE (CAR L))
- (MAP-1 (CDR L)))
- (BEGIN
- (IF (NOT (NULL? L))
- (BAD-END))
+ `(set! ,name
+ (named-lambda (,name ,@extra-vars procedure first . rest)
+
+ (define (map-1 l)
+ (if (pair? l)
+ (,combiner (procedure (car l))
+ (map-1 (cdr l)))
+ (begin
+ (if (not (null? l))
+ (bad-end))
,initial-value)))
- (DEFINE (MAP-2 L1 L2)
- (IF (AND (PAIR? L1) (PAIR? L2))
- (,combiner (PROCEDURE (CAR L1) (CAR L2))
- (MAP-2 (CDR L1) (CDR L2)))
- (BEGIN
- (IF (NOT (AND (OR (NULL? L1) (PAIR? L1))
- (OR (NULL? L2) (PAIR? L2))))
- (BAD-END))
+ (define (map-2 l1 l2)
+ (if (and (pair? l1) (pair? l2))
+ (,combiner (procedure (car l1) (car l2))
+ (map-2 (cdr l1) (cdr l2)))
+ (begin
+ (if (not (and (or (null? l1) (pair? l1))
+ (or (null? l2) (pair? l2))))
+ (bad-end))
,initial-value)))
- (DEFINE (MAP-N LISTS)
- (LET SPLIT ((LISTS LISTS) (CARS '()) (CDRS '()))
- (IF (PAIR? LISTS)
- (IF (PAIR? (CAR LISTS))
- (SPLIT (CDR LISTS)
- (CONS (CAR (CAR LISTS)) CARS)
- (CONS (CDR (CAR LISTS)) CDRS))
- (BEGIN
- (IF (NOT (NULL? (CAR LISTS)))
- (BAD-END))
+ (define (map-n lists)
+ (let split ((lists lists) (cars '()) (cdrs '()))
+ (if (pair? lists)
+ (if (pair? (car lists))
+ (split (cdr lists)
+ (cons (car (car lists)) cars)
+ (cons (cdr (car lists)) cdrs))
+ (begin
+ (if (not (null? (car lists)))
+ (bad-end))
,initial-value))
- (,combiner (APPLY PROCEDURE (REVERSE! CARS))
- (MAP-N (REVERSE! CDRS))))))
+ (,combiner (apply procedure (reverse! cars))
+ (map-n (reverse! cdrs))))))
- (DEFINE (BAD-END)
- (MAPPER-ERROR (CONS FIRST REST) ',name))
+ (define (bad-end)
+ (mapper-error (cons first rest) ',name))
- (IF (PAIR? REST)
- (IF (PAIR? (CDR REST))
- (MAP-N (CONS FIRST REST))
- (MAP-2 FIRST (CAR REST)))
- (MAP-1 FIRST)))))))))
+ (if (pair? rest)
+ (if (pair? (cdr rest))
+ (map-n (cons first rest))
+ (map-2 first (car rest)))
+ (map-1 first)))))))))
(mapper for-each () begin unspecific)
(mapper map* (initial-value) cons initial-value)
(define (fold-left procedure initial first . rest)
(if (pair? rest)
- (%fold-left-lists 'FOLD-LEFT procedure initial (cons first rest))
- (%fold-left 'FOLD-LEFT procedure initial first)))
+ (%fold-left-lists 'fold-left procedure initial (cons first rest))
+ (%fold-left 'fold-left procedure initial first)))
\f
;;; Variants of FOLD-LEFT that should probably be avoided.
;; PROCEDURE takes the arguments with the state at the right-hand end.
(define (fold procedure initial first . rest)
(if (pair? rest)
- (%fold-left-lists 'FOLD
+ (%fold-left-lists 'fold
(lambda (state . arguments)
(apply procedure (append arguments (list state))))
initial
(cons first rest))
- (%fold-left 'FOLD
+ (%fold-left 'fold
(lambda (state item)
(declare (integrate state item))
(procedure item state))
;; 4. PROCEDURE takes arguments in the wrong order.
(define (reduce procedure default list)
(if (pair? list)
- (%fold-left 'REDUCE
+ (%fold-left 'reduce
(lambda (state item)
(declare (integrate state item))
(procedure item state))
(cdr list))
(begin
(if (not (null? list))
- (error:not-a list? list 'REDUCE))
+ (error:not-a list? list 'reduce))
default)))
(define (reduce-left procedure initial list)
(procedure first (loop (car rest) (cdr rest)))
(begin
(if (not (null? rest))
- (error:not-a list? list 'REDUCE-RIGHT))
+ (error:not-a list? list 'reduce-right))
first)))
(begin
(if (not (null? list))
- (error:not-a list? list 'REDUCE-RIGHT))
+ (error:not-a list? list 'reduce-right))
initial)))
(define (fold-right procedure initial first . rest)
(cons (cdr (car lists)) cdrs))
(begin
(if (not (null? (car lists)))
- (mapper-error (cons first rest) 'FOLD-RIGHT))
+ (mapper-error (cons first rest) 'fold-right))
initial))
(apply procedure
(reverse! (cons (loop (reverse! cdrs)) cars))))))
(procedure (car list) (loop (cdr list)))
(begin
(if (not (null? list))
- (error:not-a list? first 'FOLD-RIGHT))
+ (error:not-a list? first 'fold-right))
initial)))))
\f
;;;; Generalized list operations
(loop (cdr items*)))
(begin
(if (not (null? items*))
- (error:not-a list? items 'FIND-MATCHING-ITEM))
+ (error:not-a list? items 'find-matching-item))
#f))))
(define (find-non-matching-item items predicate)
(car items*))
(begin
(if (not (null? items*))
- (error:not-a list? items 'FIND-MATCHING-ITEM))
+ (error:not-a list? items 'find-matching-item))
#f))))
(define (find-unique-matching-item items predicate)
(loop (cdr items*)))
(begin
(if (not (null? items*))
- (error:not-a list? items 'FIND-UNIQUE-MATCHING-ITEM))
+ (error:not-a list? items 'find-unique-matching-item))
#f))))
(define (find-unique-non-matching-item items predicate)
#f))
(begin
(if (not (null? items*))
- (error:not-a list? items 'FIND-UNIQUE-NON-MATCHING-ITEM))
+ (error:not-a list? items 'find-unique-non-matching-item))
#f))))
\f
(define (count-matching-items items predicate)
(n 0 (if (predicate (car items*)) (fix:+ n 1) n)))
((not (pair? items*))
(if (not (null? items*))
- (error:not-a list? items 'COUNT-MATCHING-ITEMS))
+ (error:not-a list? items 'count-matching-items))
n)))
(define (count-non-matching-items items predicate)
(n 0 (if (predicate (car items*)) n (fix:+ n 1))))
((not (pair? items*))
(if (not (null? items*))
- (error:not-a list? items 'COUNT-NON-MATCHING-ITEMS))
+ (error:not-a list? items 'count-non-matching-items))
n)))
(define (keep-matching-items items predicate)
- (let ((lose (lambda () (error:not-a list? items 'KEEP-MATCHING-ITEMS))))
+ (let ((lose (lambda () (error:not-a list? items 'keep-matching-items))))
(cond ((pair? items)
(let ((head (cons (car items) '())))
(let loop ((items* (cdr items)) (previous head))
(else (lose)))))
(define (delete-matching-items items predicate)
- (let ((lose (lambda () (error:not-a list? items 'DELETE-MATCHING-ITEMS))))
+ (let ((lose (lambda () (error:not-a list? items 'delete-matching-items))))
(cond ((pair? items)
(let ((head (cons (car items) '())))
(let loop ((items* (cdr items)) (previous head))
(lose)))))
(lose
(lambda ()
- (error:not-a list? items 'DELETE-MATCHING-ITEMS!))))
+ (error:not-a list? items 'delete-matching-items!))))
(trim-initial-segment items)))
(define (keep-matching-items! items predicate)
(lose)))))
(lose
(lambda ()
- (error:not-a list? items 'KEEP-MATCHING-ITEMS!))))
+ (error:not-a list? items 'keep-matching-items!))))
(trim-initial-segment items)))
(define ((list-deletor predicate) items)
;;;; Membership lists
(define (memq item items)
- (%member item items eq? 'MEMQ))
+ (%member item items eq? 'memq))
(define (memv item items)
- (%member item items eqv? 'MEMV))
+ (%member item items eqv? 'memv))
(define (member item items #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%member item items = 'MEMBER)))
+ (%member item items = 'member)))
(define (member-procedure = #!optional caller)
(lambda (item items)
((deletor (lambda (match) (predicate match item))) items))
\f
(define (delq item items)
- (%delete item items eq? 'DELQ))
+ (%delete item items eq? 'delq))
(define (delv item items)
- (%delete item items eqv? 'DELV))
+ (%delete item items eqv? 'delv))
(define (delete item items #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%delete item items = 'DELETE)))
+ (%delete item items = 'delete)))
(define-integrable (%delete item items = caller)
(let ((lose (lambda () (error:not-a list? items caller))))
items))))
(define (delq! item items)
- (%delete! item items eq? 'DELQ!))
+ (%delete! item items eq? 'delq!))
(define (delv! item items)
- (%delete! item items eqv? 'DELV!))
+ (%delete! item items eqv? 'delv!))
(define (delete! item items #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%delete! item items = 'DELETE!)))
+ (%delete! item items = 'delete!)))
(define-integrable (%delete! item items = caller)
(letrec
(cons (cons key datum) alist))
(define (alist-copy alist)
- (let ((lose (lambda () (error:not-a alist? alist 'ALIST-COPY))))
+ (let ((lose (lambda () (error:not-a alist? alist 'alist-copy))))
(cond ((pair? alist)
(if (pair? (car alist))
(let ((head (cons (car alist) '())))
((deletor (lambda (entry) (predicate (selector entry) key))) alist))
\f
(define (assq key alist)
- (%assoc key alist eq? 'ASSQ))
+ (%assoc key alist eq? 'assq))
(define (assv key alist)
- (%assoc key alist eqv? 'ASSV))
+ (%assoc key alist eqv? 'assv))
(define (assoc key alist #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%assoc key alist = 'ASSOC)))
+ (%assoc key alist = 'assoc)))
(define-integrable (%assoc key alist = caller)
(let ((lose (lambda () (error:not-a alist? alist caller))))
#f)))))
(define (del-assq key alist)
- (%alist-delete key alist eq? 'DEL-ASSQ))
+ (%alist-delete key alist eq? 'del-assq))
(define (del-assv key alist)
- (%alist-delete key alist eqv? 'DEL-ASSV))
+ (%alist-delete key alist eqv? 'del-assv))
(define (del-assoc key alist)
- (%alist-delete key alist equal? 'DEL-ASSOC))
+ (%alist-delete key alist equal? 'del-assoc))
(define (alist-delete key alist #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%alist-delete key alist = 'ALIST-DELETE)))
+ (%alist-delete key alist = 'alist-delete)))
(define-integrable (%alist-delete key alist = caller)
(let ((lose (lambda () (error:not-a alist? alist caller))))
alist))))
\f
(define (del-assq! key alist)
- (%alist-delete! key alist eq? 'DEL-ASSQ!))
+ (%alist-delete! key alist eq? 'del-assq!))
(define (del-assv! key alist)
- (%alist-delete! key alist eqv? 'DEL-ASSV!))
+ (%alist-delete! key alist eqv? 'del-assv!))
(define (del-assoc! key alist)
- (%alist-delete! key alist equal? 'DEL-ASSOC!))
+ (%alist-delete! key alist equal? 'del-assoc!))
(define (alist-delete! key alist #!optional =)
(let ((= (if (default-object? =) equal? =)))
- (%alist-delete! key alist = 'ALIST-DELETE!)))
+ (%alist-delete! key alist = 'alist-delete!)))
(define-integrable (%alist-delete! item items = caller)
(letrec
(define (initialize-package!)
(set! *purification-root-marker* (intern "#[PURIFICATION-ROOT]"))
(set! condition-type:not-loading
- (make-condition-type 'NOT-LOADING condition-type:error '()
+ (make-condition-type 'not-loading condition-type:error '()
"No file being loaded."))
(set! param:after-load-hooks (make-settable-parameter '()))
\f
(define (with-eval-unit uri thunk)
(parameterize*
- (list (cons param:eval-unit (->absolute-uri uri 'WITH-EVAL-UNIT)))
+ (list (cons param:eval-unit (->absolute-uri uri 'with-eval-unit)))
thunk))
(define (current-eval-unit #!optional error?)
env)))
(define (set-load-environment! environment)
- (guarantee environment? environment 'SET-LOAD-ENVIRONMENT!)
+ (guarantee environment? environment 'set-load-environment!)
(if (not (default-object? (param:current-load-environment)))
(param:current-load-environment environment)))
(define (with-load-environment environment thunk)
- (guarantee environment? environment 'WITH-LOAD-ENVIRONMENT)
+ (guarantee environment? environment 'with-load-environment)
(parameterize* (list (cons param:current-load-environment environment))
thunk))
(and (pair? pu)
(string=? (car pu) (car pl))
(loop (cdr pu) (cdr pl)))
- (make-pathname #f #f (cons 'RELATIVE pu)
+ (make-pathname #f #f (cons 'relative pu)
#f #f #f)))))))
(if path
(with-directory-rewriting-rule directory path thunk)
(begin
(set! system-base-uri (string->uri system-base-uri))
unspecific))
- (maybe-merge rel-uri system-base-uri 'SYSTEM-URI))
+ (maybe-merge rel-uri system-base-uri 'system-uri))
(define system-base-uri "http://www.gnu.org/software/mit-scheme/")
(define (system-library-uri #!optional rel-uri)
- (maybe-merge rel-uri (system-uri "lib/") 'SYSTEM-LIBRARY-URI))
+ (maybe-merge rel-uri (system-uri "lib/") 'system-library-uri))
(define (maybe-merge rel-uri base-uri caller)
(if (default-object? rel-uri)
unspecific)
\f
(define (set-command-line-parser! keyword proc #!optional description)
- (guarantee string? keyword 'SET-COMMAND-LINE-PARSER!)
+ (guarantee string? keyword 'set-command-line-parser!)
(let ((keyword (strip-leading-hyphens keyword))
(desc (if (default-object? description)
""
(begin
- (guarantee string? description 'SET-COMMAND-LINE-PARSER!)
+ (guarantee string? description 'set-command-line-parser!)
description))))
(let ((place (assoc keyword *command-line-parsers*)))
(string-append keyword-line "\n (No description.)")))
(define (simple-command-line-parser keyword thunk . description-lines)
- (guarantee string? keyword 'SIMPLE-COMMAND-LINE-PARSER)
+ (guarantee string? keyword 'simple-command-line-parser)
(set-command-line-parser! keyword
(lambda (command-line)
(values (cdr command-line) thunk))
(command-line-option-description
(string-append "--" keyword)
description-lines
- 'SIMPLE-COMMAND-LINE-PARSER)))
+ 'simple-command-line-parser)))
;; Upwards compatibility.
(define simple-option-parser simple-command-line-parser)
(command-line-option-description
(string-append "--" keyword " ARG" (if multiple? " ..." ""))
description-lines
- 'ARGUMENT-COMMAND-LINE-PARSER)))
+ 'argument-command-line-parser)))
(define (for-each-non-keyword command-line processor)
(let ((end
((ucode-primitive local-assignment)
#f ;global environment
- 'DEFINE-MULTIPLE
+ 'define-multiple
(lambda (env names values)
(if (or (not (vector? names))
(not (vector? values))
(and package
(let ((env (package/environment package)))
(if (not procedure-name)
- (if (lexical-unreferenceable? env 'INITIALIZE-PACKAGE!)
+ (if (lexical-unreferenceable? env 'initialize-package!)
((access get-boot-init-runner boot-defs) env)
- (lexical-reference env 'INITIALIZE-PACKAGE!))
+ (lexical-reference env 'initialize-package!))
(and (not (lexical-unreferenceable? env procedure-name))
(lexical-reference env procedure-name))))))
=> (lambda (procedure)
(print-name "initialize:")
(if (not (or (not procedure-name)
- (eq? procedure-name 'INITIALIZE-PACKAGE!)))
+ (eq? procedure-name 'initialize-package!)))
(begin
(tty-write-string " [")
(tty-write-string (system-pair-car procedure-name))
(do ((specs specs (cdr specs)))
((not (pair? specs)) unspecific)
(let ((spec (car specs)))
- (cond ((eq? (car spec) 'OPTIONAL)
+ (cond ((eq? (car spec) 'optional)
(package-initialize (cadr spec)
(and (pair? (cddr spec))
(caddr spec))
(intern os-name-string))
(define newline-string
- (if (eq? 'UNIX os-name)
+ (if (eq? 'unix os-name)
"\n"
"\r\n"))
\f
;; Construct the package structure.
;; Lotta hair here to load the package code before its package is built.
(eval (file->object "packag" #t #t) environment-for-package)
-((lexical-reference environment-for-package 'INITIALIZE-PACKAGE!))
+((lexical-reference environment-for-package 'initialize-package!))
(let ((export
(lambda (name)
(link-variables system-global-environment name
environment-for-package name))))
- (export '*ALLOW-PACKAGE-REDEFINITION?*)
- (export 'CONSTRUCT-PACKAGES-FROM-FILE)
- (export 'ENVIRONMENT->PACKAGE)
- (export 'FIND-PACKAGE)
- (export 'LOAD-PACKAGE-SET)
- (export 'LOAD-PACKAGES-FROM-FILE)
- (export 'NAME->PACKAGE)
- (export 'PACKAGE-SET-PATHNAME)
- (export 'PACKAGE/ADD-CHILD!)
- (export 'PACKAGE/CHILDREN)
- (export 'PACKAGE/ENVIRONMENT)
- (export 'PACKAGE/NAME)
- (export 'PACKAGE/PARENT)
- (export 'PACKAGE/REFERENCE)
- (export 'PACKAGE?))
-(package/add-child! (find-package '()) 'PACKAGE environment-for-package)
+ (export '*allow-package-redefinition?*)
+ (export 'construct-packages-from-file)
+ (export 'environment->package)
+ (export 'find-package)
+ (export 'load-package-set)
+ (export 'load-packages-from-file)
+ (export 'name->package)
+ (export 'package-set-pathname)
+ (export 'package/add-child!)
+ (export 'package/children)
+ (export 'package/environment)
+ (export 'package/name)
+ (export 'package/parent)
+ (export 'package/reference)
+ (export 'package?))
+(package/add-child! (find-package '()) 'package environment-for-package)
(define packages-file
(let ((name
(string-append "runtime-"
- (cond ((eq? os-name 'NT) "w32")
- ((eq? os-name 'UNIX) "unx")
+ (cond ((eq? os-name 'nt) "w32")
+ ((eq? os-name 'unix) "unx")
(else "unk"))
".pkd")))
(or (initialize-c-compiled-block (string-append runtime-prefix name))
(fasload name #f))))
-((lexical-reference environment-for-package 'CONSTRUCT-PACKAGES-FROM-FILE)
+((lexical-reference environment-for-package 'construct-packages-from-file)
packages-file)
\f
;;; Global databases. Load, then initialize.
(define boot-defs)
(let ((files0
- '(("gcdemn" . (RUNTIME GC-DAEMONS))
- ("gc" . (RUNTIME GARBAGE-COLLECTOR))
- ("boot" . (RUNTIME BOOT-DEFINITIONS))
- ("queue" . (RUNTIME SIMPLE-QUEUE))
- ("equals" . (RUNTIME EQUALITY))
- ("list" . (RUNTIME LIST))
+ '(("gcdemn" . (runtime gc-daemons))
+ ("gc" . (runtime garbage-collector))
+ ("boot" . (runtime boot-definitions))
+ ("queue" . (runtime simple-queue))
+ ("equals" . (runtime equality))
+ ("list" . (runtime list))
("primitive-arithmetic" . (runtime primitive-arithmetic))
("srfi-1" . (runtime srfi-1))
("thread-low" . (runtime thread))
- ("vector" . (RUNTIME VECTOR))))
+ ("vector" . (runtime vector))))
(files1
'(("string" . (runtime string))
- ("symbol" . (RUNTIME SYMBOL))
+ ("symbol" . (runtime symbol))
("procedure" . (runtime procedure))
- ("random" . (RUNTIME RANDOM-NUMBER))
+ ("random" . (runtime random-number))
("dispatch-tag" . (runtime tagged-dispatch))
- ("poplat" . (RUNTIME POPULATION))
- ("record" . (RUNTIME RECORD))
+ ("poplat" . (runtime population))
+ ("record" . (runtime record))
("bundle" . (runtime bundle))))
(files2
'(("syntax-low" . (runtime syntax low))
- ("thread" . (RUNTIME THREAD))
- ("wind" . (RUNTIME STATE-SPACE))
- ("prop1d" . (RUNTIME 1D-PROPERTY))
- ("events" . (RUNTIME EVENT-DISTRIBUTOR))
- ("gdatab" . (RUNTIME GLOBAL-DATABASE))
- ("gcfinal" . (RUNTIME GC-FINALIZER))))
+ ("thread" . (runtime thread))
+ ("wind" . (runtime state-space))
+ ("prop1d" . (runtime 1d-property))
+ ("events" . (runtime event-distributor))
+ ("gdatab" . (runtime global-database))
+ ("gcfinal" . (runtime gc-finalizer))))
(load-files
(lambda (files)
(do ((files files (cdr files)))
(load-files files0)
(set! boot-defs
- (package/environment (name->package '(RUNTIME BOOT-DEFINITIONS))))
+ (package/environment (name->package '(runtime boot-definitions))))
(load-files-with-boot-inits files1)
- (package-initialize '(RUNTIME GC-DAEMONS) #f #t)
- (package-initialize '(RUNTIME GARBAGE-COLLECTOR) #f #t)
- (package-initialize '(RUNTIME RANDOM-NUMBER) #f #t)
+ (package-initialize '(runtime gc-daemons) #f #t)
+ (package-initialize '(runtime garbage-collector) #f #t)
+ (package-initialize '(runtime random-number) #f #t)
(package-initialize '(runtime tagged-dispatch) #f #t)
- (package-initialize '(RUNTIME POPULATION) #f #t)
+ (package-initialize '(runtime population) #f #t)
(package-initialize '(runtime record) #f #t)
(package-initialize '(runtime bundle) #f #t)
(load-files-with-boot-inits files2)
- (package-initialize '(RUNTIME 1D-PROPERTY) #f #t) ;First population.
- (package-initialize '(RUNTIME STATE-SPACE) #f #t)
- (package-initialize '(RUNTIME THREAD) 'INITIALIZE-LOW! #t) ;First 1d-table.
- (package-initialize '(RUNTIME EVENT-DISTRIBUTOR) #f #t)
- (package-initialize '(RUNTIME GLOBAL-DATABASE) #f #t)
- (package-initialize '(RUNTIME POPULATION) 'INITIALIZE-UNPARSER! #t)
- (package-initialize '(RUNTIME 1D-PROPERTY) 'INITIALIZE-UNPARSER! #t)
- (package-initialize '(RUNTIME GC-FINALIZER) #f #t)
+ (package-initialize '(runtime 1d-property) #f #t) ;First population.
+ (package-initialize '(runtime state-space) #f #t)
+ (package-initialize '(runtime thread) 'initialize-low! #t) ;First 1d-table.
+ (package-initialize '(runtime event-distributor) #f #t)
+ (package-initialize '(runtime global-database) #f #t)
+ (package-initialize '(runtime population) 'initialize-unparser! #t)
+ (package-initialize '(runtime 1d-property) 'initialize-unparser! #t)
+ (package-initialize '(runtime gc-finalizer) #f #t)
;; Load everything else.
- ((lexical-reference environment-for-package 'LOAD-PACKAGES-FROM-FILE)
+ ((lexical-reference environment-for-package 'load-packages-from-file)
packages-file
- `((SORT-TYPE . MERGE-SORT)
- (OS-TYPE . ,os-name)
- (OPTIONS . NO-LOAD))
+ `((sort-type . merge-sort)
+ (os-type . ,os-name)
+ (options . no-load))
(let ((file-member?
(lambda (filename files)
(let loop ((files files))
(package-initialization-sequence
'(
;; Microcode interface
- ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!)
- (RUNTIME APPLY)
- (RUNTIME PRIMITIVE-IO)
- (RUNTIME SYSTEM-CLOCK)
- ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS!)
+ ((runtime microcode-tables) read-microcode-tables!)
+ (runtime apply)
+ (runtime primitive-io)
+ (runtime system-clock)
+ ((runtime gc-finalizer) initialize-events!)
;; Basic data structures
- (RUNTIME NUMBER)
- ((RUNTIME NUMBER) INITIALIZE-DRAGON4!)
- (RUNTIME MISCELLANEOUS-GLOBAL)
- (RUNTIME CHARACTER)
- (RUNTIME BYTEVECTOR)
- (RUNTIME CHARACTER-SET)
- (RUNTIME LAMBDA-ABSTRACTION)
+ (runtime number)
+ ((runtime number) initialize-dragon4!)
+ (runtime miscellaneous-global)
+ (runtime character)
+ (runtime bytevector)
+ (runtime character-set)
+ (runtime lambda-abstraction)
(runtime string)
- (RUNTIME STREAM)
- (RUNTIME 2D-PROPERTY)
- (RUNTIME HASH-TABLE)
- (RUNTIME MEMOIZER)
- (RUNTIME UCD-TABLES)
- (RUNTIME UCD-GLUE)
- (RUNTIME BLOWFISH)
- (RUNTIME PREDICATE)
- (RUNTIME PREDICATE-TAGGING)
- (RUNTIME PREDICATE-DISPATCH)
- (RUNTIME COMPOUND-PREDICATE)
- (RUNTIME PARAMETRIC-PREDICATE)
- (RUNTIME HASH)
- (RUNTIME DYNAMIC)
- (RUNTIME REGULAR-SEXPRESSION)
+ (runtime stream)
+ (runtime 2d-property)
+ (runtime hash-table)
+ (runtime memoizer)
+ (runtime ucd-tables)
+ (runtime ucd-glue)
+ (runtime blowfish)
+ (runtime predicate)
+ (runtime predicate-tagging)
+ (runtime predicate-dispatch)
+ (runtime compound-predicate)
+ (runtime parametric-predicate)
+ (runtime hash)
+ (runtime dynamic)
+ (runtime regular-sexpression)
;; Microcode data structures
- (RUNTIME HISTORY)
- (RUNTIME SCODE)
- (RUNTIME SCODE-WALKER)
- (RUNTIME CONTINUATION-PARSER)
- (RUNTIME PROGRAM-COPIER)
+ (runtime history)
+ (runtime scode)
+ (runtime scode-walker)
+ (runtime continuation-parser)
+ (runtime program-copier)
;; Finish records
- ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!)
- ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!)
- ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!)
+ ((runtime record) initialize-record-procedures!)
+ ((package) finalize-package-record-type!)
+ ((runtime random-number) finalize-random-state-type!)
;; Condition System
- (RUNTIME ERROR-HANDLER)
- (RUNTIME MICROCODE-ERRORS)
+ (runtime error-handler)
+ (runtime microcode-errors)
((runtime record) initialize-conditions!)
- ((RUNTIME STREAM) INITIALIZE-CONDITIONS!)
- ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!)
+ ((runtime stream) initialize-conditions!)
+ ((runtime regular-sexpression) initialize-conditions!)
;; System dependent stuff
- ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!)
+ ((runtime os-primitives) initialize-system-primitives!)
;; Floating-point environment -- needed by threads.
- (RUNTIME FLOATING-POINT-ENVIRONMENT)
- ((RUNTIME THREAD) INITIALIZE-HIGH!)
+ (runtime floating-point-environment)
+ ((runtime thread) initialize-high!)
;; I/O
- (RUNTIME PORT)
- (RUNTIME OUTPUT-PORT)
- (RUNTIME GENERIC-I/O-PORT)
- (RUNTIME FILE-I/O-PORT)
- (RUNTIME CONSOLE-I/O-PORT)
- (RUNTIME SOCKET)
- (RUNTIME STRING-I/O-PORT)
- (RUNTIME USER-INTERFACE)
+ (runtime port)
+ (runtime output-port)
+ (runtime generic-i/o-port)
+ (runtime file-i/o-port)
+ (runtime console-i/o-port)
+ (runtime socket)
+ (runtime string-i/o-port)
+ (runtime user-interface)
;; These MUST be done before (RUNTIME PATHNAME)
;; Typically only one of them is loaded.
- (RUNTIME PATHNAME UNIX)
- (RUNTIME PATHNAME DOS)
- (RUNTIME PATHNAME)
- (RUNTIME DIRECTORY)
- (RUNTIME WORKING-DIRECTORY)
- (RUNTIME LOAD)
- (RUNTIME SIMPLE-FILE-OPS)
- (OPTIONAL (RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES!)
+ (runtime pathname unix)
+ (runtime pathname dos)
+ (runtime pathname)
+ (runtime directory)
+ (runtime working-directory)
+ (runtime load)
+ (runtime simple-file-ops)
+ (optional (runtime os-primitives) initialize-mime-types!)
;; Syntax
- (RUNTIME NUMBER-PARSER)
- (RUNTIME OPTIONS)
- (RUNTIME PARSER)
- (RUNTIME FILE-ATTRIBUTES)
- ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!)
- (RUNTIME UNPARSER)
- (RUNTIME UNSYNTAXER)
- (RUNTIME PRETTY-PRINTER)
- (RUNTIME EXTENDED-SCODE-EVAL)
+ (runtime number-parser)
+ (runtime options)
+ (runtime parser)
+ (runtime file-attributes)
+ ((runtime pathname) initialize-parser-method!)
+ (runtime unparser)
+ (runtime unsyntaxer)
+ (runtime pretty-printer)
+ (runtime extended-scode-eval)
(runtime syntax items)
(runtime syntax rename)
(runtime syntax top-level)
(runtime syntax parser)
;; REP Loops
- (RUNTIME INTERRUPT-HANDLER)
- (RUNTIME GC-STATISTICS)
- (RUNTIME GC-NOTIFICATION)
- (RUNTIME REP)
+ (runtime interrupt-handler)
+ (runtime gc-statistics)
+ (runtime gc-notification)
+ (runtime rep)
;; Debugging
- (RUNTIME COMPILER-INFO)
- (RUNTIME ADVICE)
- (RUNTIME DEBUGGER-COMMAND-LOOP)
- (RUNTIME DEBUGGER-UTILITIES)
- (RUNTIME ENVIRONMENT-INSPECTOR)
- (RUNTIME DEBUGGING-INFO)
- (RUNTIME DEBUGGER)
+ (runtime compiler-info)
+ (runtime advice)
+ (runtime debugger-command-loop)
+ (runtime debugger-utilities)
+ (runtime environment-inspector)
+ (runtime debugging-info)
+ (runtime debugger)
;; Misc (e.g., version)
- (RUNTIME)
- (RUNTIME CRYPTO)
+ (runtime)
+ (runtime crypto)
;; Graphics. The last type initialized is the default for
;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the
;; operating system are actually loaded and initialized.
- (OPTIONAL (RUNTIME X-GRAPHICS))
+ (optional (runtime x-graphics))
;; Emacs -- last because it installs hooks everywhere which must be initted.
- (RUNTIME EMACS-INTERFACE)
+ (runtime emacs-interface)
;; More debugging
- (OPTIONAL (RUNTIME CONTINUATION-PARSER) INITIALIZE-SPECIAL-FRAMES!)
- (RUNTIME URI)
- (RUNTIME RFC2822-HEADERS)
- (RUNTIME HTTP-SYNTAX)
- (RUNTIME HTML-FORM-CODEC)
- (OPTIONAL (RUNTIME WIN32-REGISTRY))
- (OPTIONAL (RUNTIME FFI))
- (RUNTIME SAVE/RESTORE)
- (RUNTIME STRUCTURE-PARSER)
- (RUNTIME SWANK)
- (RUNTIME STACK-SAMPLER)
+ (optional (runtime continuation-parser) initialize-special-frames!)
+ (runtime uri)
+ (runtime rfc2822-headers)
+ (runtime http-syntax)
+ (runtime html-form-codec)
+ (optional (runtime win32-registry))
+ (optional (runtime ffi))
+ (runtime save/restore)
+ (runtime structure-parser)
+ (runtime swank)
+ (runtime stack-sampler)
;; Last since it turns on runtime handling of microcode errors.
((runtime microcode-errors) initialize-error-hooks!)))
\f
(if obj
(eval obj system-global-environment)))
-(link-variables (->environment '(RUNTIME ENVIRONMENT)) 'PACKAGE-NAME-TAG
- (->environment '(PACKAGE)) 'PACKAGE-NAME-TAG)
+(link-variables (->environment '(runtime environment)) 'package-name-tag
+ (->environment '(package)) 'package-name-tag)
(let ((roots
(list->vector
- ((lexical-reference (->environment '(RUNTIME COMPILER-INFO))
- 'WITH-DIRECTORY-REWRITING-RULE)
+ ((lexical-reference (->environment '(runtime compiler-info))
+ 'with-directory-rewriting-rule)
(working-directory-pathname)
(pathname-as-directory "runtime")
(lambda ()
(let ((fasload/update-debugging-info!
- (lexical-reference (->environment '(RUNTIME COMPILER-INFO))
- 'FASLOAD/UPDATE-DEBUGGING-INFO!))
+ (lexical-reference (->environment '(runtime compiler-info))
+ 'fasload/update-debugging-info!))
(load/purification-root
- (lexical-reference (->environment '(RUNTIME LOAD))
- 'LOAD/PURIFICATION-ROOT)))
+ (lexical-reference (->environment '(runtime load))
+ 'load/purification-root)))
(map (lambda (entry)
(let ((object (cdr entry)))
(fasload/update-debugging-info! object (car entry))
(load/purification-root object)))
fasload-purification-queue)))))))
- (lexical-assignment (->environment '(RUNTIME GARBAGE-COLLECTOR))
- 'GC-BOOT-LOADING?
+ (lexical-assignment (->environment '(runtime garbage-collector))
+ 'gc-boot-loading?
#f)
(set! fasload-purification-queue)
(newline console-output-port)
)
-(package/add-child! (find-package '()) 'USER user-initial-environment)
+(package/add-child! (find-package '()) 'user user-initial-environment)
;; Might be better to do this sooner, to trap on floating-point
;; mistakes earlier in the cold load.
(flo:set-environment! (flo:default-environment))
(define (signal-variable-error continuation signal-reference signal-other)
(let ((frame (continuation/first-subproblem continuation)))
(case (frame/type frame)
- ((EVAL-ERROR)
+ ((eval-error)
(let ((expression (eval-frame/expression frame)))
(if (scode-variable? expression)
(signal-reference (eval-frame/environment frame)
(scode-variable-name expression)))))
- ((ASSIGNMENT-CONTINUE)
+ ((assignment-continue)
(signal-other (eval-frame/environment frame)
(scode-assignment-name (eval-frame/expression frame))))
- ((ACCESS-CONTINUE)
+ ((access-continue)
(signal-reference (pop-return-frame/value continuation)
(scode-access-name (eval-frame/expression frame))))
- ((INTERNAL-APPLY INTERNAL-APPLY-VAL)
+ ((internal-apply internal-apply-val)
(let ((operator (apply-frame/operator frame)))
(cond ((or (eq? (ucode-primitive lexical-reference) operator)
(eq? (ucode-primitive safe-lexical-reference 2)
((eq? (ucode-primitive lexical-unassigned?) operator)
(signal-other (apply-frame/operand frame 0)
(apply-frame/operand frame 1))))))
- ((COMPILER-REFERENCE-TRAP-RESTART
- COMPILER-SAFE-REFERENCE-TRAP-RESTART)
+ ((compiler-reference-trap-restart
+ compiler-safe-reference-trap-restart)
(signal-reference (reference-trap-frame/environment frame)
(reference-trap-frame/name frame)))
- ((COMPILER-ASSIGNMENT-TRAP-RESTART
- COMPILER-UNASSIGNED?-TRAP-RESTART
- COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
+ ((compiler-assignment-trap-restart
+ compiler-unassigned?-trap-restart
+ compiler-operator-lookup-trap-restart)
(signal-other (reference-trap-frame/environment frame)
(reference-trap-frame/name frame))))))
\f
(write-operator (access-condition condition 'operator) port)
(write-string " is not implemented for this operating system." port))))
-(define-primitive-error 'UNDEFINED-PRIMITIVE-OPERATION
+(define-primitive-error 'undefined-primitive-operation
condition-type:unimplemented-primitive-for-os)
(set! condition-type:compiled-code-error
(if (string=? "SIGFPE" name)
((case (and (string? code)
(normalize-trap-code-name code))
- ((DIVIDE-BY-ZERO) signal-divide-by-zero)
- ((FLOATING-POINT-DIVIDE-BY-ZERO)
+ ((divide-by-zero) signal-divide-by-zero)
+ ((floating-point-divide-by-zero)
signal-floating-point-divide-by-zero)
- ((INEXACT-RESULT)
+ ((inexact-result)
signal-inexact-floating-point-result)
- ((INTEGER-DIVIDE-BY-ZERO)
+ ((integer-divide-by-zero)
signal-integer-divide-by-zero)
- ((INVALID-OPERATION)
+ ((invalid-operation)
signal-invalid-floating-point-operation)
- ((OVERFLOW) signal-floating-point-overflow)
- ((UNDERFLOW) signal-floating-point-underflow)
+ ((overflow) signal-floating-point-overflow)
+ ((underflow) signal-floating-point-underflow)
(else signal-arithmetic-error))
k #f '())
(signal-hardware-trap k name code)))))))))
\f
(define (read-microcode-tables!)
(set! identification-vector ((ucode-primitive microcode-identify)))
- (set! errors-slot (fixed-object/name->code 'MICROCODE-ERRORS-VECTOR))
+ (set! errors-slot (fixed-object/name->code 'microcode-errors-vector))
(set! identifications-slot
- (fixed-object/name->code 'MICROCODE-IDENTIFICATION-VECTOR))
- (set! returns-slot (fixed-object/name->code 'MICROCODE-RETURNS-VECTOR))
+ (fixed-object/name->code 'microcode-identification-vector))
+ (set! returns-slot (fixed-object/name->code 'microcode-returns-vector))
(set! terminations-slot
- (fixed-object/name->code 'MICROCODE-TERMINATIONS-VECTOR))
- (set! types-slot (fixed-object/name->code 'MICROCODE-TYPES-VECTOR))
- (set! non-object-slot (fixed-object/name->code 'NON-OBJECT))
- (set! system-call-names-slot (fixed-object/name->code 'SYSTEM-CALL-NAMES))
- (set! system-call-errors-slot (fixed-object/name->code 'SYSTEM-CALL-ERRORS))
+ (fixed-object/name->code 'microcode-terminations-vector))
+ (set! types-slot (fixed-object/name->code 'microcode-types-vector))
+ (set! non-object-slot (fixed-object/name->code 'non-object))
+ (set! system-call-names-slot (fixed-object/name->code 'system-call-names))
+ (set! system-call-errors-slot (fixed-object/name->code 'system-call-errors))
(set! microcode-version-string
- (microcode-identification-item 'MICROCODE-VERSION))
- (set! char:newline (microcode-identification-item 'NEWLINE-CHAR))
+ (microcode-identification-item 'microcode-version))
+ (set! char:newline (microcode-identification-item 'newline-char))
(set! microcode-id/floating-mantissa-bits
- (microcode-identification-item 'FLONUM-MANTISSA-LENGTH))
+ (microcode-identification-item 'flonum-mantissa-length))
(set! microcode-id/floating-epsilon
- (microcode-identification-item 'FLONUM-EPSILON))
- (let ((name (microcode-identification-item 'OS-NAME-STRING)))
+ (microcode-identification-item 'flonum-epsilon))
+ (let ((name (microcode-identification-item 'os-name-string)))
(set! microcode-id/operating-system (intern name))
(set! microcode-id/operating-system-name name))
(set! microcode-id/operating-system-variant
- (microcode-identification-item 'OS-VARIANT-STRING))
+ (microcode-identification-item 'os-variant-string))
(set! microcode-id/stack-type
- (let ((string (microcode-identification-item 'STACK-TYPE-STRING)))
+ (let ((string (microcode-identification-item 'stack-type-string)))
(cond ((string? string) (intern string))
- ((not string) 'STANDARD)
+ ((not string) 'standard)
(else (error "Illegal stack type:" string)))))
(set! microcode-id/machine-type
- (or (microcode-identification-item 'MACHINE-TYPE-STRING #f)
+ (or (microcode-identification-item 'machine-type-string #f)
"unknown-machine"))
(set! microcode-id/compiled-code-type
- (intern (or (microcode-identification-item 'CC-ARCH-STRING #f)
+ (intern (or (microcode-identification-item 'cc-arch-string #f)
"unknown")))
(set! microcode-id/tty-x-size
- (microcode-identification-item 'CONSOLE-WIDTH))
+ (microcode-identification-item 'console-width))
(set! microcode-id/tty-y-size
- (microcode-identification-item 'CONSOLE-HEIGHT))
+ (microcode-identification-item 'console-height))
unspecific)
(case (if (default-object? os-type)
microcode-id/operating-system
os-type)
- ((NT) "w32")
- ((UNIX) "unx")
+ ((nt) "w32")
+ ((unix) "unx")
(else (error "Unknown operating system:" os-type))))
\f
(define-integrable fixed-objects-slot 15)
(define (microcode-identification-vector-slot name #!optional error?)
(let ((v (microcode-table-search identifications-slot name)))
(if (and (not v) (if (default-object? error?) #t error?))
- (error:bad-range-argument name 'MICROCODE-IDENTIFICATION-VECTOR-SLOT))
+ (error:bad-range-argument name 'microcode-identification-vector-slot))
v))
(define (microcode-identification-item name #!optional error?)
(vector-length (vector-ref (get-fixed-objects-vector) types-slot)))
(define type-aliases
- '((FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT)
- (PAIR LIST)
- (FLONUM BIG-FLONUM)
- (CONSTANT TRUE)
- (RETURN-CODE RETURN-ADDRESS)
- (BIGNUM BIG-FIXNUM)
- (PROMISE DELAYED)
- (FIXNUM ADDRESS POSITIVE-FIXNUM NEGATIVE-FIXNUM)
- (STRING CHARACTER-STRING VECTOR-8B)
- (HUNK3-A UNMARKED-HISTORY)
- (TRIPLE HUNK3 HUNK3-B MARKED-HISTORY)
- (REFERENCE-TRAP UNASSIGNED)
- (RECNUM COMPLEX)))
\ No newline at end of file
+ '((false manifest-vector global-environment)
+ (pair list)
+ (flonum big-flonum)
+ (constant true)
+ (return-code return-address)
+ (bignum big-fixnum)
+ (promise delayed)
+ (fixnum address positive-fixnum negative-fixnum)
+ (string character-string vector-8b)
+ (hunk3-a unmarked-history)
+ (triple hunk3 hunk3-b marked-history)
+ (reference-trap unassigned)
+ (recnum complex)))
\ No newline at end of file
(define (merge-sort! v pred)
(if (not (vector? v))
- (error:wrong-type-argument v "vector" 'MERGE-SORT!))
+ (error:wrong-type-argument v "vector" 'merge-sort!))
(let sort-subvector
((v v)
(temp (vector-copy v))
((or (char=? #\x char) (char=? #\X char))
(do-radix 16))
((or (char=? #\e char) (char=? #\E char))
- (do-exactness 'EXACT))
+ (do-exactness 'exact))
((or (char=? #\i char) (char=? #\I char))
- (do-exactness 'INEXACT))
+ (do-exactness 'inexact))
(else #f))))))
(parse-top-level string start end exactness
(or radix default-radix))))))
((char=? #\. char)
(and (or (not radix) (fix:= 10 radix))
(parse-decimal-1 string start end
- (or exactness 'IMPLICIT-INEXACT) #f)))
+ (or exactness 'implicit-inexact) #f)))
((char->digit char (or radix 10))
=> (lambda (digit)
(parse-integer string start end digit
((char=? #\. char)
(and (fix:= 10 radix)
(parse-decimal-1 string start end
- (or exactness 'IMPLICIT-INEXACT) sign)))
+ (or exactness 'implicit-inexact) sign)))
((i? char)
(and (fix:= start end)
(make-rectangular 0 (if (eq? #\- sign) -1 1))))
integer 0 exactness sign)
(parse-decimal-2 string start+1 end
integer 0
- (or exactness 'IMPLICIT-INEXACT)
+ (or exactness 'implicit-inexact)
sign))))
((exponent-marker? char)
(and (fix:= radix 10)
(parse-exponent-1 string start+1 end
integer 0
- (or exactness 'IMPLICIT-INEXACT)
+ (or exactness 'implicit-inexact)
sign)))
(else
(parse-complex string start end
(integer (* integer radix) (* integer radix)))
((not (and (fix:< start end)
(char=? #\# (string-ref string start))))
- (k start integer (or exactness 'IMPLICIT-INEXACT) #t))))
+ (k start integer (or exactness 'implicit-inexact) #t))))
(else
(k start integer exactness #f))))
(k start integer exactness #f))))
(if (fix:< start end)
(let ((char (string-ref string start))
(start+1 (fix:+ start 1))
- (exactness (if (eq? 'IMPLICIT-INEXACT exactness) #f exactness)))
+ (exactness (if (eq? 'implicit-inexact exactness) #f exactness)))
(cond ((sign? char)
(let ((imaginary
(parse-top-level string start end exactness radix)))
(* (apply-sign sign integer)
(expt 10 exponent))))
- (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness))
+ (if (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness))
(let ((abs-exponent (if (< exponent 0) (- exponent) exponent))
(powers-of-10 exact-flonum-powers-of-10))
(define-integrable (finish-flonum x power-of-10)
number))
(define (apply-exactness exactness number)
- (if (or (eq? 'INEXACT exactness) (eq? 'IMPLICIT-INEXACT exactness))
+ (if (or (eq? 'inexact exactness) (eq? 'implicit-inexact exactness))
(exact->inexact number)
number))
(lambda ()
(load pathname
environment
- 'DEFAULT
+ 'default
#t))))))))))
files)
(flush-purification-queue!)
(if (fix:< low high)
(let ((index (fix:quotient (fix:+ low high) 2)))
(case (order key (item-key (vector-ref vector index)))
- ((LESS) (loop low index))
- ((GREATER) (loop (fix:+ index 1) high))
+ ((less) (loop low index))
+ ((greater) (loop (fix:+ index 1) high))
(else (if-found index))))
(if-not-found low))))
\ No newline at end of file
(unparse-object/top-level object port #t environment))
(define (output-port/x-size port)
- (or (let ((operation (textual-port-operation port 'X-SIZE)))
+ (or (let ((operation (textual-port-operation port 'x-size)))
(and operation
(operation port)))
80))
(define (output-port/y-size port)
- (let ((operation (textual-port-operation port 'Y-SIZE)))
+ (let ((operation (textual-port-operation port 'y-size)))
(and operation
(operation port))))
(define (output-port/column port)
- (let ((operation (textual-port-operation port 'OUTPUT-COLUMN)))
+ (let ((operation (textual-port-operation port 'output-column)))
(and operation
(operation port))))
(define (output-port/bytes-written port)
- (let ((operation (textual-port-operation port 'BYTES-WRITTEN)))
+ (let ((operation (textual-port-operation port 'bytes-written)))
(and operation
(operation port))))
(define (output-port/synchronize-output port)
- (let ((operation (textual-port-operation port 'SYNCHRONIZE-OUTPUT)))
+ (let ((operation (textual-port-operation port 'synchronize-output)))
(if operation
(operation port))))
\f
;;;; High level
(define (write-char char #!optional port)
- (let ((port (optional-output-port port 'WRITE-CHAR)))
+ (let ((port (optional-output-port port 'write-char)))
(if (let ((n (output-port/write-char port char)))
(and n
(fix:> n 0)))
(optional-output-port port 'synchronize-output-port)))
\f
(define (fresh-line #!optional port)
- (let ((port (optional-output-port port 'FRESH-LINE)))
+ (let ((port (optional-output-port port 'fresh-line)))
(if (let ((n (output-port/fresh-line port)))
(and n
(fix:> n 0)))
(output-port/discretionary-flush port))))
(define (display object #!optional port environment)
- (let ((port (optional-output-port port 'DISPLAY)))
+ (let ((port (optional-output-port port 'display)))
(unparse-object/top-level object port #f environment)
(output-port/discretionary-flush port)))
(define (write object #!optional port environment)
- (let ((port (optional-output-port port 'WRITE)))
+ (let ((port (optional-output-port port 'write)))
(output-port/write-object port object environment)
(output-port/discretionary-flush port)))
(define (write-line object #!optional port environment)
- (let ((port (optional-output-port port 'WRITE-LINE)))
+ (let ((port (optional-output-port port 'write-line)))
(output-port/write-object port object environment)
(output-port/write-char port #\newline)
(output-port/discretionary-flush port)))
(operation port)
(output-port/discretionary-flush port)))))))
-(define beep (wrap-custom-operation-0 'BEEP))
-(define clear (wrap-custom-operation-0 'CLEAR))
+(define beep (wrap-custom-operation-0 'beep))
+(define clear (wrap-custom-operation-0 'clear))
(define (optional-output-port port caller)
(let ((port (if (default-object? port) (current-output-port) port)))
left-margin col-sep right-margin)
(if (not (list-of-type? strings string?))
(error:wrong-type-argument strings "list of strings"
- 'WRITE-STRINGS-IN-COLUMNS))
- (guarantee textual-output-port? port 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee exact-positive-integer? min-minor 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee string? left-margin 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee string? col-sep 'WRITE-STRINGS-IN-COLUMNS)
- (guarantee string? right-margin 'WRITE-STRINGS-IN-COLUMNS)
+ 'write-strings-in-columns))
+ (guarantee textual-output-port? port 'write-strings-in-columns)
+ (guarantee exact-positive-integer? min-minor 'write-strings-in-columns)
+ (guarantee string? left-margin 'write-strings-in-columns)
+ (guarantee string? col-sep 'write-strings-in-columns)
+ (guarantee string? right-margin 'write-strings-in-columns)
(let ((n-strings (length strings))
(max-width (output-port/x-size port))
(lm-width (string-length left-margin))
(if (and (not (list-of-type? strings string?))
(pair? strings))
(error:wrong-type-argument strings "non-empty list of strings"
- 'WRITE-STRINGS-IN-PARAGRAPH))
- (guarantee textual-output-port? port 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee exact-positive-integer? width 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee exact-nonnegative-integer? indent 'WRITE-STRINGS-IN-PARAGRAPH)
- (guarantee exact-nonnegative-integer? first 'WRITE-STRINGS-IN-PARAGRAPH)
+ 'write-strings-in-paragraph))
+ (guarantee textual-output-port? port 'write-strings-in-paragraph)
+ (guarantee exact-positive-integer? width 'write-strings-in-paragraph)
+ (guarantee exact-nonnegative-integer? indent 'write-strings-in-paragraph)
+ (guarantee exact-nonnegative-integer? first 'write-strings-in-paragraph)
(if (< width (+ indent first (string-length (car strings))))
- (error:bad-range-argument width 'WRITE-STRINGS-IN-PARAGRAPH))
+ (error:bad-range-argument width 'write-strings-in-paragraph))
(fresh-line port)
(write-spaces indent port)
(parser-buffer-base-offset buffer))))
(if (<= (parser-buffer-start buffer) p* (parser-buffer-index buffer))
p*
- (error:bad-range-argument p 'POINTER->INDEX)))
- (error:wrong-type-argument p "parser-buffer pointer" 'POINTER->INDEX)))
+ (error:bad-range-argument p 'pointer->index)))
+ (error:wrong-type-argument p "parser-buffer pointer" 'pointer->index)))
(define (parser-buffer-position-string object)
(let ((pointer
(define (parser-buffer-ref buffer index)
(if (not (index-fixnum? index))
- (error:wrong-type-argument index "index" 'PARSER-BUFFER-REF))
+ (error:wrong-type-argument index "index" 'parser-buffer-ref))
(and (guarantee-buffer-chars buffer (fix:+ index 1))
(string-ref (parser-buffer-string buffer)
(fix:+ (parser-buffer-index buffer) index))))
(%grow-buffer string end min-end))))
(let ((port (parser-buffer-port buffer))
(string (parser-buffer-string buffer)))
- (with-input-port-blocking-mode port 'BLOCKING
+ (with-input-port-blocking-mode port 'blocking
(lambda ()
(let loop ((end end))
(if (fix:< end min-end)
;;; Look for keyword-style: prefix or keyword-style: suffix
(define (process-keyword-attribute file-attribute-alist db)
(let ((keyword-entry
- (lookup-file-attribute file-attribute-alist 'KEYWORD-STYLE)))
+ (lookup-file-attribute file-attribute-alist 'keyword-style)))
(if (pair? keyword-entry)
(let ((value (cdr keyword-entry)))
(cond ((and (symbol? value)
(define (process-mode-attribute file-attribute-alist db)
(declare (ignore db))
(let ((mode-entry
- (lookup-file-attribute file-attribute-alist 'MODE)))
+ (lookup-file-attribute file-attribute-alist 'mode)))
(if (pair? mode-entry)
(let ((value (cdr mode-entry)))
(if (or (not (symbol? value))
;; the attribute and the value don't matter.
(define (process-studly-case-attribute file-attribute-alist db)
(let ((studly-case-entry
- (lookup-file-attribute file-attribute-alist 'STUDLY-CASE)))
+ (lookup-file-attribute file-attribute-alist 'studly-case)))
(if (pair? studly-case-entry)
(let ((value (cdr studly-case-entry)))
(cond ((or (eq? value #t)
(warn "Unrecognized value for sTuDly-case" value)))))))
\f
(define-deferred condition-type:parse-error
- (make-condition-type 'PARSE-ERROR condition-type:error '()
+ (make-condition-type 'parse-error condition-type:error '()
(lambda (condition port)
condition
(write-string "Anonymous parsing error." port))))
(lambda (form environment)
environment
(if (syntax-match? '(identifier * identifier) (cdr form))
- `(BEGIN
+ `(begin
,@(let loop ((names (cddr form)) (index 0))
(if (pair? names)
- `((DEFINE ,(car names) ,index)
+ `((define ,(car names) ,index)
,@(loop (cdr names) (+ index 1)))
'()))
- (DEFINE ,(cadr form) '#(,@(cddr form))))
+ (define ,(cadr form) '#(,@(cddr form))))
(ill-formed-syntax form)))))
(define (index->name index enum)
- (guarantee index-fixnum? index 'INDEX->NAME)
+ (guarantee index-fixnum? index 'index->name)
(if (not (fix:< index (vector-length enum)))
- (error:bad-range-argument index 'INDEX->NAME))
+ (error:bad-range-argument index 'index->name))
(vector-ref enum index))
(define-enum connection-status
- PGSQL-CONNECTION-OK
- PGSQL-CONNECTION-BAD
- PGSQL-CONNECTION-STARTED
- PGSQL-CONNECTION-MADE
- PGSQL-CONNECTION-AWAITING-RESPONSE
- PGSQL-CONNECTION-AUTH-OK
- PGSQL-CONNECTION-SETENV)
+ pgsql-connection-ok
+ pgsql-connection-bad
+ pgsql-connection-started
+ pgsql-connection-made
+ pgsql-connection-awaiting-response
+ pgsql-connection-auth-ok
+ pgsql-connection-setenv)
(define-enum postgres-polling-status
- PGSQL-POLLING-FAILED
- PGSQL-POLLING-READING
- PGSQL-POLLING-WRITING
- PGSQL-POLLING-OK
- PGSQL-POLLING-ACTIVE)
+ pgsql-polling-failed
+ pgsql-polling-reading
+ pgsql-polling-writing
+ pgsql-polling-ok
+ pgsql-polling-active)
(define-enum exec-status
- PGSQL-EMPTY-QUERY
- PGSQL-COMMAND-OK
- PGSQL-TUPLES-OK
- PGSQL-COPY-OUT
- PGSQL-COPY-IN
- PGSQL-BAD-RESPONSE
- PGSQL-NONFATAL-ERROR
- PGSQL-FATAL-ERROR)
+ pgsql-empty-query
+ pgsql-command-ok
+ pgsql-tuples-ok
+ pgsql-copy-out
+ pgsql-copy-in
+ pgsql-bad-response
+ pgsql-nonfatal-error
+ pgsql-fatal-error)
\f
(define pgsql-initialized? #f)
(define connections)
(if (syntax-match? '(symbol expression) (cdr form))
(let ((type (cadr form)))
(let ((type? (symbol type '?))
- (guarantee-type (symbol 'GUARANTEE- type))
- (error:not-type (symbol 'ERROR:NOT- type))
- (guarantee-valid-type (symbol 'GUARANTEE-VALID- type))
- (type-handle (symbol type '-HANDLE)))
- `(BEGIN
- (DEFINE-INTEGRABLE (,guarantee-type OBJECT CALLER)
- (IF (NOT (,type? OBJECT))
- (,error:not-type OBJECT CALLER)))
- (DEFINE (,error:not-type OBJECT CALLER)
- (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,(caddr form) CALLER))
- (DEFINE-INTEGRABLE (,guarantee-valid-type OBJECT CALLER)
- (IF (AND (,type? OBJECT) (,type-handle OBJECT))
- (,type-handle OBJECT)
- (,error:not-type OBJECT CALLER))))))
+ (guarantee-type (symbol 'guarantee- type))
+ (error:not-type (symbol 'error:not- type))
+ (guarantee-valid-type (symbol 'guarantee-valid- type))
+ (type-handle (symbol type '-handle)))
+ `(begin
+ (define-integrable (,guarantee-type object caller)
+ (if (not (,type? object))
+ (,error:not-type object caller)))
+ (define (,error:not-type object caller)
+ (error:wrong-type-argument object ,(caddr form) caller))
+ (define-integrable (,guarantee-valid-type object caller)
+ (if (and (,type? object) (,type-handle object))
+ (,type-handle object)
+ (,error:not-type object caller))))))
(ill-formed-syntax form)))))
(define-guarantee connection "PostgreSQL connection")
(error "This Scheme system was built without PostgreSQL support.")))
\f
(define condition-type:pgsql-error
- (make-condition-type 'PGSQL-ERROR condition-type:error '()
+ (make-condition-type 'pgsql-error condition-type:error '()
(lambda (condition port)
condition
(write-string "Unknown PostgreSQL error." port))))
(define condition-type:pgsql-connection-error
- (make-condition-type 'PGSQL-CONNECTION-ERROR condition-type:pgsql-error
- '(MESSAGE)
+ (make-condition-type 'pgsql-connection-error condition-type:pgsql-error
+ '(message)
(lambda (condition port)
(write-string "Unable to connect to PostgreSQL server" port)
- (write-message (access-condition condition 'MESSAGE) port))))
+ (write-message (access-condition condition 'message) port))))
(define error:pgsql-connection
(condition-signaller condition-type:pgsql-connection-error
- '(MESSAGE)
+ '(message)
standard-error-handler))
(define condition-type:pgsql-query-error
- (make-condition-type 'PGSQL-QUERY-ERROR condition-type:pgsql-error
- '(QUERY RESULT)
+ (make-condition-type 'pgsql-query-error condition-type:pgsql-error
+ '(query result)
(lambda (condition port)
(write-string "PostgreSQL query error" port)
(write-message
- (pgsql-result-error-message (access-condition condition 'RESULT))
+ (pgsql-result-error-message (access-condition condition 'result))
port))))
(define error:pgsql-query
(condition-signaller condition-type:pgsql-query-error
- '(QUERY RESULT)
+ '(query result)
standard-error-handler))
(define (write-message string port)
(lambda (handle)
(cond ((= 0 handle)
(error:pgsql-connection #f))
- ((= PGSQL-CONNECTION-BAD (pq-status handle))
+ ((= pgsql-connection-bad (pq-status handle))
(let ((msg (pq-error-message handle)))
(pq-finish handle)
(error:pgsql-connection msg))))
unspecific))))
(define (pgsql-conn-open? connection)
- (guarantee-connection connection 'PGSQL-CONN-OPEN?)
+ (guarantee-connection connection 'pgsql-conn-open?)
(if (connection-handle connection) #t #f))
(define-integrable (connection->handle connection)
- (guarantee-valid-connection connection 'CONNECTION->HANDLE))
+ (guarantee-valid-connection connection 'connection->handle))
(define (poll-pgsql-conn connection)
(index->name (pq-connect-poll (connection->handle connection))
environment
(if (syntax-match? '(symbol) (cdr form))
(let ((field (cadr form)))
- `(DEFINE (,(symbol 'PGSQL-CONN- field) OBJECT)
- (,(symbol 'PQ- field) (CONNECTION->HANDLE OBJECT))))
+ `(define (,(symbol 'pgsql-conn- field) object)
+ (,(symbol 'pq- field) (connection->handle object))))
(ill-formed-syntax form)))))
(define-connection-accessor db)
(pq-unescape-bytea string))
\f
(define (exec-pgsql-query connection query)
- (guarantee string? query 'EXEC-PGSQL-QUERY)
+ (guarantee string? query 'exec-pgsql-query)
(let ((result
(let ((handle (connection->handle connection)))
(make-gc-finalized-object
(error "Unable to execute PostgreSQL query:" query))
(make-result result-handle))))))
(if (not (memq (pgsql-result-status result)
- '(PGSQL-COMMAND-OK
- PGSQL-TUPLES-OK
- PGSQL-COPY-OUT
- PGSQL-COPY-IN)))
+ '(pgsql-command-ok
+ pgsql-tuples-ok
+ pgsql-copy-out
+ pgsql-copy-in)))
(error:pgsql-query query result))
result))
(make-result result-handle)))))
(define-integrable (result->handle result)
- (guarantee-valid-result result 'RESULT->HANDLE))
+ (guarantee-valid-result result 'result->handle))
(define-syntax define-result-accessor
(sc-macro-transformer
environment
(if (syntax-match? '(symbol) (cdr form))
(let ((field (cadr form)))
- `(DEFINE (,(symbol 'PGSQL- field) OBJECT)
- (,(symbol 'PQ- field) (RESULT->HANDLE OBJECT))))
+ `(define (,(symbol 'pgsql- field) object)
+ (,(symbol 'pq- field) (result->handle object))))
(ill-formed-syntax form)))))
(define-result-accessor result-error-message)
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! population-tag
- (standard-unparser-method 'POPULATION #f)))
+ (standard-unparser-method 'population #f)))
-(define bogus-false '(BOGUS-FALSE))
-(define population-tag '(POPULATION))
+(define bogus-false '(bogus-false))
+(define population-tag '(population))
(define-integrable (canonicalize object)
(if (eq? object false) bogus-false object))
;; NAMED: just name if the procedure is a named lambda, like FULL if unnamed
;; SHORT: procedures appear in #[...] unparser syntax
(set! param:pp-arity-dispatched-procedure-style
- (make-settable-parameter 'FULL))
+ (make-settable-parameter 'full))
(set! param:pp-auto-highlighter (make-settable-parameter #f))
(set! param:pp-avoid-circularity? (make-settable-parameter #f))
(set! param:pp-default-as-code? (make-settable-parameter #t))
(set! print-case-expression (special-printer kernel/print-case-expression))
(set! code-dispatch-list
(make-unsettable-parameter
- `((COND . ,forced-indentation)
- (CASE . ,print-case-expression)
- (IF . ,forced-indentation)
- (OR . ,forced-indentation)
- (AND . ,forced-indentation)
- (LET . ,print-let-expression)
- (LET* . ,print-let-expression)
- (LETREC . ,print-let-expression)
- (FLUID-LET . ,print-let-expression)
- (DEFINE . ,print-procedure)
- (DEFINE-INTEGRABLE . ,print-procedure)
- (LAMBDA . ,print-procedure)
- (NAMED-LAMBDA . ,print-procedure))))
+ `((cond . ,forced-indentation)
+ (case . ,print-case-expression)
+ (if . ,forced-indentation)
+ (or . ,forced-indentation)
+ (and . ,forced-indentation)
+ (let . ,print-let-expression)
+ (let* . ,print-let-expression)
+ (letrec . ,print-let-expression)
+ (fluid-let . ,print-let-expression)
+ (define . ,print-procedure)
+ (define-integrable . ,print-procedure)
+ (lambda . ,print-procedure)
+ (named-lambda . ,print-procedure))))
(set! dispatch-list (make-unsettable-parameter (code-dispatch-list)))
(set! dispatch-default (make-unsettable-parameter print-combination))
(set! cocked-object (generate-uninterned-symbol))
(define-pp-describer weak-pair?
(lambda (wp)
- `((WEAK-CAR ,(weak-car wp))
- (WEAK-CDR ,(weak-cdr wp)))))
+ `((weak-car ,(weak-car wp))
+ (weak-cdr ,(weak-cdr wp)))))
(define-pp-describer cell?
(lambda (cell)
- `((CONTENTS ,(cell-contents cell)))))))
+ `((contents ,(cell-contents cell)))))))
\f
(define (unsyntax-entity object)
(define (unsyntax-entry procedure)
(case (get-param:pp-arity-dispatched-procedure-style)
- ((FULL) (unsyntax-entity procedure))
- ((NAMED)
+ ((full) (unsyntax-entity procedure))
+ ((named)
(let ((text (unsyntax-entity procedure)))
(if (and (pair? text)
(eq? (car text) 'named-lambda)
(pair? (cadr text)))
(caadr text)
text)))
- ((SHORT) procedure)
+ ((short) procedure)
(else procedure)))
(cond ((arity-dispatched-procedure? object)
(let* ((default (entity-procedure object))
(cdr cases)))
(else
(loop (+ i 1) tests (cdr cases)))))))
- `(CASE NUMBER-OF-ARGUMENTS
+ `(case number-of-arguments
,@cases*
- (ELSE
+ (else
,(unsyntax-entry default)))))
((and (procedure? object) (procedure-lambda object))
=> unsyntax)
(unsyntax object))))
(if (and as-code?
(pair? sexp)
- (eq? (car sexp) 'NAMED-LAMBDA)
+ (eq? (car sexp) 'named-lambda)
(get-param:pp-named-lambda->define?))
- (if (and (eq? 'LAMBDA
+ (if (and (eq? 'lambda
(get-param:pp-named-lambda->define?))
(pair? (cdr sexp))
(pair? (cadr sexp)))
- `(LAMBDA ,(cdadr sexp) ,@(cddr sexp))
- `(DEFINE ,@(cdr sexp)))
+ `(lambda ,(cdadr sexp) ,@(cddr sexp))
+ `(define ,@(cdr sexp)))
sexp))
(if (default-object? port) (current-output-port) port)
as-code?
(object #f read-only #t)
(start-string "*=>" read-only #t)
(end-string "<=*" read-only #t)
- (as-code? 'DEFAULT read-only #t)
- (depth-limit 'DEFAULT read-only #t)
- (breadth-limit 'DEFAULT read-only #t))
+ (as-code? 'default read-only #t)
+ (depth-limit 'default read-only #t)
+ (breadth-limit 'default read-only #t))
(define (with-highlight-strings-printed pph thunk)
(let ((print-string
(let ((handler
(let ((as-code? (pph/as-code? highlight))
(currently-as-code? (not (null? (dispatch-list)))))
- (cond ((or (eq? as-code? 'DEFAULT)
+ (cond ((or (eq? as-code? 'default)
(eq? as-code? currently-as-code?))
print-node)
(as-code?
(let ((dl (pph/depth-limit object)))
(parameterize* (list (cons param:unparser-list-breadth-limit
(let ((bl (pph/breadth-limit object)))
- (if (eq? bl 'DEFAULT)
+ (if (eq? bl 'default)
(param:unparser-list-breadth-limit)
bl)))
(cons param:unparser-list-depth-limit
- (if (eq? dl 'DEFAULT)
+ (if (eq? dl 'default)
(param:unparser-list-depth-limit)
dl)))
(lambda ()
(numerical-walk (pph/object object)
- (if (eq? dl 'DEFAULT)
+ (if (eq? dl 'default)
list-depth
0))))))
prefix
(numerical-walk-terminating
(cadr object)
- (advance half-pointer (update-queue queue '(CDR CAR)))
+ (advance half-pointer (update-queue queue '(cdr car)))
list-depth))
(walk-pair-terminating object half-pointer/queue
list-depth))))
(let ((half-pointer/queue
(advance
(car half-pointer/queue)
- (update-queue (cdr half-pointer/queue) '(CAR)))))
+ (update-queue (cdr half-pointer/queue) '(car)))))
(if (eq? (car half-pointer/queue) (car pair))
(circularity-string (cdr half-pointer/queue))
(numerical-walk-terminating
(let ((half-pointer/queue
(advance
(car half-pointer/queue)
- (update-queue (cdr half-pointer/queue) '(CAR)))))
+ (update-queue (cdr half-pointer/queue) '(car)))))
(if (eq? (car half-pointer/queue) (car pair))
(circularity-string (cdr half-pointer/queue))
(numerical-walk-terminating
(let ((half-pointer/queue
(advance
(car half-pointer/queue)
- (update-queue (cdr half-pointer/queue) '(CDR)))))
+ (update-queue (cdr half-pointer/queue) '(cdr)))))
(if (eq? (car half-pointer/queue) (cdr pair))
(make-singleton-list-node
(string-append
(advance
(car half-pointer/queue)
(update-queue
- (cdr half-pointer/queue) '(CDR)))))
+ (cdr half-pointer/queue) '(cdr)))))
(if (eq? (car half-pointer/queue) (cdr pair))
(circularity-string (cdr half-pointer/queue))
(numerical-walk-terminating
(define (update-queue queue command-list)
(define (uq-iter queue command-list)
(cond ((null? command-list) queue)
- ((eq? (car command-list) 'CAR)
+ ((eq? (car command-list) 'car)
(uq-iter (add-car queue) (cdr command-list)))
- ((eq? (car command-list) 'CDR)
+ ((eq? (car command-list) 'cdr)
(uq-iter (add-cdr queue) (cdr command-list)))
(else
(uq-iter (add-vector-ref (car command-list) queue)
(object-new-type primitive-object-new-type 2))
(define (initialize-package!)
- (set! *copy-constants?* (make-unsettable-parameter 'UNBOUND))
- (set! *object-copies* (make-unsettable-parameter 'UNBOUND))
+ (set! *copy-constants?* (make-unsettable-parameter 'unbound))
+ (set! *object-copies* (make-unsettable-parameter 'unbound))
(set! copier/scode-walker
(make-scode-walker
copy-constant
- `((ACCESS ,(%copy-pair (ucode-type ACCESS)))
- (ASSIGNMENT ,(%copy-triple (ucode-type ASSIGNMENT)))
- (COMBINATION ,copy-COMBINATION-object)
- (COMMENT ,copy-COMMENT-object)
- (CONDITIONAL ,(%copy-triple (ucode-type CONDITIONAL)))
- (DEFINITION ,(%copy-pair (ucode-type DEFINITION)))
- (DELAY ,(%copy-pair (ucode-type DELAY)))
- (DISJUNCTION ,(%copy-pair (ucode-type DISJUNCTION)))
- (LAMBDA ,copy-LAMBDA-object)
- (QUOTATION ,(%copy-pair (ucode-type QUOTATION)))
- (SEQUENCE ,copy-SEQUENCE-object)
- (THE-ENVIRONMENT ,copy-constant)
- (VARIABLE ,copy-VARIABLE-object))))
+ `((access ,(%copy-pair (ucode-type access)))
+ (assignment ,(%copy-triple (ucode-type assignment)))
+ (combination ,copy-combination-object)
+ (comment ,copy-comment-object)
+ (conditional ,(%copy-triple (ucode-type conditional)))
+ (definition ,(%copy-pair (ucode-type definition)))
+ (delay ,(%copy-pair (ucode-type delay)))
+ (disjunction ,(%copy-pair (ucode-type disjunction)))
+ (lambda ,copy-lambda-object)
+ (quotation ,(%copy-pair (ucode-type quotation)))
+ (sequence ,copy-sequence-object)
+ (the-environment ,copy-constant)
+ (variable ,copy-variable-object))))
unspecific)
\f
;;;; Top level
(define copier/scode-walker)
(define-integrable (make-object-association-table)
- (list '*OBJECT-COPIES*))
+ (list '*object-copies*))
(define-integrable (object-association object)
(assq object (cdr (*object-copies*))))
(boolean? obj)
(null? obj)
(char? obj)
- (object-type? (ucode-type REFERENCE-TRAP) obj))
+ (object-type? (ucode-type reference-trap) obj))
obj)
((pair? obj)
- (%%copy-pair (ucode-type PAIR) obj))
+ (%%copy-pair (ucode-type pair) obj))
((vector? obj)
- (%%copy-vector (ucode-type VECTOR) obj))
+ (%%copy-vector (ucode-type vector) obj))
((string? obj)
(let ((copy (string-copy obj)))
(add-association! obj copy)
(%copy-compiled-code-block obj))))
(define (%copy-compiled-code-block obj)
- (let* ((new (vector-copy (object-new-type (ucode-type VECTOR) obj)))
+ (let* ((new (vector-copy (object-new-type (ucode-type vector) obj)))
(typed (object-new-type (ucode-type compiled-code-block) new))
(len (vector-length new)))
((ucode-primitive declare-compiled-code-block 1) typed)
(let ((association (object-association vec)))
(if association
(cdr association)
- (%%copy-vector (ucode-type VECTOR) vec))))
+ (%%copy-vector (ucode-type vector) vec))))
(define ((%copy-vector type) obj)
(%%copy-vector type obj))
(define (%%copy-vector type obj)
(let* ((new (vector-copy
- (object-new-type (ucode-type VECTOR) obj)))
+ (object-new-type (ucode-type vector) obj)))
(typed (object-new-type type new))
(len (vector-length new)))
(add-association! obj typed)
(vector-set! new i (copy-object (vector-ref new i))))
typed))
\f
-(define (copy-SEQUENCE-object obj)
- (if (object-type? (ucode-type SEQUENCE) obj)
- (%%copy-pair (ucode-type SEQUENCE) obj)
- (error "copy-SEQUENCE-object: Unknown type" obj)))
+(define (copy-sequence-object obj)
+ (if (object-type? (ucode-type sequence) obj)
+ (%%copy-pair (ucode-type sequence) obj)
+ (error "copy-sequence-object: Unknown type" obj)))
-(define (copy-COMBINATION-object obj)
+(define (copy-combination-object obj)
(make-scode-combination
(copy-object (scode-combination-operator obj))
(map copy-object (scode-combination-operands obj))))
-(define (copy-LAMBDA-object obj)
+(define (copy-lambda-object obj)
(cond ((object-type? (ucode-type lambda) obj)
(%%copy-pair (ucode-type lambda) obj))
((object-type? (ucode-type extended-lambda) obj)
((object-type? (ucode-type lexpr) obj)
(%%copy-pair (ucode-type lexpr) obj))
(else
- (error "COPY-LAMBDA-object: Unknown type" obj))))
+ (error "copy-lambda-object: Unknown type" obj))))
-(define (copy-VARIABLE-object obj)
+(define (copy-variable-object obj)
(let ((var (make-scode-variable (scode-variable-name obj))))
(add-association! obj var)
var))
-(define (copy-COMMENT-object obj)
+(define (copy-comment-object obj)
(let ((the-text (scode-comment-text obj)))
(if (not (dbg-info-vector? the-text))
- (%%copy-pair (ucode-type COMMENT) obj)
+ (%%copy-pair (ucode-type comment) obj)
(let ((the-car (system-pair-car obj))
(the-cdr (system-pair-cdr obj)))
(let* ((new (cons the-car the-cdr))
- (typed (object-new-type (ucode-type COMMENT) new)))
+ (typed (object-new-type (ucode-type comment) new)))
(add-association! obj typed)
(let ((text-copy (copy-dbg-info-vector the-text)))
(set-car! new (if (eq? the-car the-text)
(cond (association
(cdr association))
((vector? obj)
- (%%copy-vector (ucode-type VECTOR) obj))
+ (%%copy-vector (ucode-type vector) obj))
((pair? obj)
;; Guarantee that top-level vectors are copied.
(for-each (lambda (element)
(cond ((flo:< x y) x)
((flo:> x y) y)
((flo:= x y) x)
- (else (error:bad-range-argument (if (flo:finite? x) x y) 'FLO:MIN))))
+ (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:min))))
(define (flo:max x y)
(cond ((flo:< x y) y)
((flo:> x y) x)
((flo:= x y) y)
- (else (error:bad-range-argument (if (flo:finite? x) x y) 'FLO:MAX))))
+ (else (error:bad-range-argument (if (flo:finite? x) x y) 'flo:max))))
;;; XXX FLO:FINITE?, FLO:NAN?, FLO:EQV?, &c., are cute, but should be
;;; replaced by primitives.
((ucode-primitive integer->flonum 2) n #b10))
(define (->flonum x)
- (guarantee real? x '->FLONUM)
+ (guarantee real? x '->flonum)
(exact->inexact (real-part x)))
;;;; Exact integers
(define (encode-select-registry-mode mode)
(case mode
- ((READ) 1)
- ((WRITE) 2)
- ((READ/WRITE) 3)
+ ((read) 1)
+ ((write) 2)
+ ((read/write) 3)
(else (error:bad-range-argument mode 'encode-select-registry-mode))))
(define (decode-select-registry-mode mode)
(lambda (procedure) procedure #f)
%compound-procedure-lambda
compiled-procedure/lambda
- 'PROCEDURE-LAMBDA))
+ 'procedure-lambda))
(define (procedure-environment procedure)
(discriminate-procedure procedure
(lambda (procedure)
(error:bad-range-argument procedure
- 'PROCEDURE-ENVIRONMENT))
+ 'procedure-environment))
%compound-procedure-environment
compiled-procedure/environment
- 'PROCEDURE-ENVIRONMENT))
+ 'procedure-environment))
(define (procedure-components procedure receiver)
(discriminate-procedure procedure
(lambda (procedure)
(error:bad-range-argument procedure
- 'PROCEDURE-COMPONENTS))
+ 'procedure-components))
(lambda (procedure)
(receiver
(%compound-procedure-lambda procedure)
(receiver
(compiled-procedure/lambda procedure)
(compiled-procedure/environment procedure)))
- 'PROCEDURE-COMPONENTS))
+ 'procedure-components))
(declare (integrate-operator discriminate-procedure))
(define (discriminate-procedure procedure if-primitive if-compound if-compiled
(loop (entity-procedure p) (fix:+ e 1))))
(else
(error:wrong-type-argument procedure "procedure"
- 'PROCEDURE-ARITY)))))
+ 'procedure-arity)))))
(define (procedure-arity-valid? procedure arity)
(procedure-arity<= arity (procedure-arity procedure)))
(error:bad-range-argument object caller)))
\f
(define (make-procedure-arity min #!optional max simple-ok?)
- (guarantee index-fixnum? min 'MAKE-PROCEDURE-ARITY)
+ (guarantee index-fixnum? min 'make-procedure-arity)
(let ((max
(if (default-object? max)
min
(begin
(if max
(begin
- (guarantee index-fixnum? max 'MAKE-PROCEDURE-ARITY)
+ (guarantee index-fixnum? max 'make-procedure-arity)
(if (not (fix:>= max min))
(error:bad-range-argument max
- 'MAKE-PROCEDURE-ARITY))))
+ 'make-procedure-arity))))
max))))
(if (and (eqv? min max)
(if (default-object? simple-ok?) #f simple-ok?))
(define (procedure-arity-min arity)
(cond ((simple-arity? arity) arity)
((general-arity? arity) (car arity))
- (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MIN))))
+ (else (error:not-a procedure-arity? arity 'procedure-arity-min))))
(define (procedure-arity-max arity)
(cond ((simple-arity? arity) arity)
((general-arity? arity) (cdr arity))
- (else (error:not-a procedure-arity? arity 'PROCEDURE-ARITY-MAX))))
+ (else (error:not-a procedure-arity? arity 'procedure-arity-max))))
(define (procedure-arity<= arity1 arity2)
(and (fix:<= (procedure-arity-min arity2)
(define (primitive-procedure-name procedure)
(%primitive-procedure-name
- (%primitive-procedure-arg procedure 'PRIMITIVE-PROCEDURE-NAME)))
+ (%primitive-procedure-arg procedure 'primitive-procedure-name)))
(define (implemented-primitive-procedure? procedure)
(%primitive-procedure-implemented?
- (%primitive-procedure-arg procedure 'IMPLEMENTED-PRIMITIVE-PROCEDURE?)))
+ (%primitive-procedure-arg procedure 'implemented-primitive-procedure?)))
(define (%primitive-procedure-arg procedure caller)
(let ((procedure* (skip-entities procedure)))
(+ (loop (entity-procedure p)) 1)))
(else
(error:wrong-type-argument procedure "compiled procedure"
- 'COMPILED-PROCEDURE-FRAME-SIZE)))))
+ 'compiled-procedure-frame-size)))))
(define (%compiled-closure? object)
(and (%compiled-procedure? object)
(let ((closure* (skip-entities closure)))
(if (not (%compiled-closure? closure*))
(error:wrong-type-argument closure "compiled closure"
- 'COMPILED-CLOSURE->ENTRY))
+ 'compiled-closure->entry))
closure*)))
;; In the following two procedures, offset can be #f to support
(%make-entity procedure extra))
(define (entity-procedure entity)
- (guarantee-entity entity 'ENTITY-PROCEDURE)
+ (guarantee-entity entity 'entity-procedure)
(%entity-procedure entity))
(define (entity-extra entity)
- (guarantee-entity entity 'ENTITY-EXTRA)
+ (guarantee-entity entity 'entity-extra)
(%entity-extra entity))
(define (set-entity-procedure! entity procedure)
- (guarantee-entity entity 'SET-ENTITY-PROCEDURE!)
+ (guarantee-entity entity 'set-entity-procedure!)
(if (procedure-chains-to procedure entity)
- (error:bad-range-argument procedure 'SET-ENTITY-PROCEDURE!))
+ (error:bad-range-argument procedure 'set-entity-procedure!))
(%set-entity-procedure! entity procedure))
(define (set-entity-extra! entity extra)
- (guarantee-entity entity 'SET-ENTITY-EXTRA!)
+ (guarantee-entity entity 'set-entity-extra!)
(%set-entity-extra! entity extra))
\f
(define (make-apply-hook procedure extra)
"apply-hook-tag")
(define (apply-hook-procedure apply-hook)
- (guarantee-apply-hook apply-hook 'APPLY-HOOK-PROCEDURE)
+ (guarantee-apply-hook apply-hook 'apply-hook-procedure)
(system-hunk3-cxr1 (%entity-extra apply-hook)))
(define (apply-hook-extra apply-hook)
- (guarantee-apply-hook apply-hook 'APPLY-HOOK-EXTRA)
+ (guarantee-apply-hook apply-hook 'apply-hook-extra)
(system-hunk3-cxr2 (%entity-extra apply-hook)))
(define (set-apply-hook-procedure! apply-hook procedure)
- (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-PROCEDURE!)
+ (guarantee-apply-hook apply-hook 'set-apply-hook-procedure!)
(if (procedure-chains-to procedure apply-hook)
- (error:bad-range-argument procedure 'SET-APPLY-HOOK-PROCEDURE!))
+ (error:bad-range-argument procedure 'set-apply-hook-procedure!))
(system-hunk3-set-cxr1! (%entity-extra apply-hook) procedure))
(define (set-apply-hook-extra! apply-hook procedure)
- (guarantee-apply-hook apply-hook 'SET-APPLY-HOOK-EXTRA!)
+ (guarantee-apply-hook apply-hook 'set-apply-hook-extra!)
(system-hunk3-set-cxr2! (%entity-extra apply-hook) procedure))
\f
;;;; Arity dispatched entities
;; SELF argument.
(make-entity default
(list->vector
- (cons (fixed-objects-item 'ARITY-DISPATCHER-TAG)
+ (cons (fixed-objects-item 'arity-dispatcher-tag)
dispatched-cases))))
(define (arity-dispatched-procedure? object)
(vector? (entity-extra object))
(fix:< 0 (vector-length (entity-extra object)))
(eq? (vector-ref (entity-extra object) 0)
- (fixed-objects-item 'ARITY-DISPATCHER-TAG))))
+ (fixed-objects-item 'arity-dispatcher-tag))))
(define (procedure-chains-to p1 p2)
(let loop ((p1 p1))
(let ((ctty-allowed? (string? ctty)))
(define-integrable (convert-stdio-arg stdio)
(cond ((not stdio) #f)
- ((eq? stdio 'INHERIT) -1)
- ((and ctty-allowed? (eq? stdio 'CTTY)) -2)
+ ((eq? stdio 'inherit) -1)
+ ((and ctty-allowed? (eq? stdio 'ctty)) -2)
((channel? stdio) (channel-descriptor stdio))
(else
(error:wrong-type-argument stdio "process I/O channel"
- 'MAKE-SUBPROCESS))))
+ 'make-subprocess))))
(let ((working-directory #f)
(ctty
- (cond ((eq? ctty 'BACKGROUND) -1)
- ((eq? ctty 'FOREGROUND) -2)
+ (cond ((eq? ctty 'background) -1)
+ ((eq? ctty 'foreground) -2)
((or (not ctty) (string? ctty)) ctty)
(else
(error:wrong-type-argument
ctty
"process controlling terminal"
- 'MAKE-SUBPROCESS))))
+ 'make-subprocess))))
(stdin (convert-stdio-arg stdin))
(stdout (convert-stdio-arg stdout))
(stderr (convert-stdio-arg stderr)))
(add-to-gc-finalizer! subprocess-finalizer process)
(poll-subprocess-status process)
process))))))))
- (if (and (eq? ctty 'FOREGROUND)
- (eq? (subprocess-status process) 'RUNNING))
+ (if (and (eq? ctty 'foreground)
+ (eq? (subprocess-status process) 'running))
(subprocess-continue-foreground process))
process))
(lambda ()
(set! registration
(register-subprocess-event
- process 'RUNNING (current-thread)
+ process 'running (current-thread)
(named-lambda (subprocess-wait-event status)
(set! result status)))))
(lambda ()
(lambda ()
(if (eq? result '#f)
(suspend-current-thread))
- (if (eq? result 'RUNNING)
+ (if (eq? result 'running)
(set! result #f))))
(if (not result)
(loop)
((ucode-primitive process-continue-foreground 1)
(subprocess-index process))
(let ((status (subprocess-status process)))
- (if (eq? status 'RUNNING)
+ (if (eq? status 'running)
(loop)
status))))
(define (convert-subprocess-status status)
(case status
- ((0) 'RUNNING)
- ((1) 'STOPPED)
- ((2) 'EXITED)
- ((3) 'SIGNALLED)
+ ((0) 'running)
+ ((1) 'stopped)
+ ((2) 'exited)
+ ((3) 'signalled)
(else (error "Illegal process status:" status))))
(define (subprocess-job-control-status process)
((ucode-primitive process-job-control-status 1)
(subprocess-index process))))
(case n
- ((0) 'NO-CTTY)
- ((1) 'UNRELATED-CTTY)
- ((2) 'NO-JOB-CONTROL)
- ((3) 'JOB-CONTROL)
+ ((0) 'no-ctty)
+ ((1) 'unrelated-ctty)
+ ((2) 'no-job-control)
+ ((3) 'job-control)
(else (error "Illegal process job-control status:" n)))))
\f
;;;; Subprocess Events
(define (deregister-subprocess-event registration)
(guarantee-subprocess-registration registration
- 'DEREGISTER-SUBPROCESS-EVENT)
+ 'deregister-subprocess-event)
(without-interrupts
(lambda ()
(set! subprocess-registrations
\f
(define (handle-subprocess-status-change)
(without-interrupts %handle-subprocess-status-change)
- (if (eq? 'NT microcode-id/operating-system)
+ (if (eq? 'nt microcode-id/operating-system)
(for-each (lambda (process)
- (if (memq (subprocess-status process) '(EXITED SIGNALLED))
+ (if (memq (subprocess-status process) '(exited signalled))
(close-subprocess-i/o process)))
(subprocess-list))))
(filter! (lambda (registration)
(let ((status
(subprocess-registration/status registration)))
- (not (or (eq? status 'EXITED)
- (eq? status 'SIGNALLED)))))
+ (not (or (eq? status 'exited)
+ (eq? status 'signalled)))))
subprocess-registrations))
(if signaled? (%maybe-toggle-thread-timer)))))
(maybe-close-subprocess-i/o process))
(define (maybe-close-subprocess-i/o process)
- (if (eq? 'NT microcode-id/operating-system)
+ (if (eq? 'nt microcode-id/operating-system)
(close-subprocess-i/o process)))
(define (subprocess-stop process)
(define (start-subprocess-in-background filename arguments environment)
(make-subprocess filename arguments environment
- 'BACKGROUND 'INHERIT 'INHERIT 'INHERIT
+ 'background 'inherit 'inherit 'inherit
#f #f #f))
(define (run-subprocess-in-foreground filename arguments environment)
(make-subprocess filename arguments environment
- 'FOREGROUND 'INHERIT 'INHERIT 'INHERIT
+ 'foreground 'inherit 'inherit 'inherit
#f #f #f))
(define (start-pipe-subprocess filename arguments environment)
(lambda (master-channel master-name slave-name)
master-name
(make-subprocess filename arguments environment
- slave-name 'CTTY 'CTTY 'CTTY
+ slave-name 'ctty 'ctty 'ctty
master-channel master-channel master-channel))))
\f
;;;; Environment Bindings
(define (initialize-unparser!)
(unparser/set-tagged-pair-method! 1d-table-tag
- (standard-unparser-method '1D-TABLE #f)))
+ (standard-unparser-method '1d-table #f)))
(define population-of-1d-tables)
|#
;;;; Two Dimensional Property Tables
-;;; package: (runtime 2D-property)
+;;; package: (runtime 2d-property)
(declare (usual-integrations))
\f
(define system-properties)
-(define (2D-put! x y value)
+(define (2d-put! x y value)
(let ((x-hash (object-hash x))
(y-hash (object-hash y)))
(let ((bucket (assq x-hash system-properties)))
'()))
system-properties))))))
-(define (2D-get x y)
+(define (2d-get x y)
(let ((bucket (assq (object-hash x) system-properties)))
(and bucket
(let ((entry (assq (object-hash y) (cdr bucket))))
;;; Returns TRUE iff an entry was removed.
;;; Removes the bucket if the entry removed was the only entry.
-(define (2D-remove! x y)
+(define (2d-remove! x y)
(let ((bucket (assq (object-hash x) system-properties)))
(and bucket
(begin (set-cdr! bucket
(define delete-invalid-hash-numbers!)
(define delete-invalid-y!)
-(define (2D-get-alist-x x)
+(define (2d-get-alist-x x)
(let ((bucket (assq (object-hash x) system-properties)))
(if bucket
(let loop ((rest (cdr bucket)))
(else (loop (cdr rest)))))
'())))
-(define (2D-get-alist-y y)
+(define (2d-get-alist-y y)
(let ((y-hash (object-hash y)))
(let loop ((rest system-properties))
(cond ((null? rest) '())
(vector-set! vector j ith-element)))
(if (not (vector? vector))
- (error:wrong-type-argument vector "vector" 'QUICK-SORT!))
+ (error:wrong-type-argument vector "vector" 'quick-sort!))
(outer-loop 0 (fix:- (vector-length vector) 1))
vector)
\ No newline at end of file
(with-queue-lock queue (lambda () (dequeue!/unsafe queue))))
(define (queue-map! queue procedure)
- (let ((empty (list 'EMPTY)))
+ (let ((empty (list 'empty)))
(let loop ()
(let ((item
(with-queue-lock queue
;;;; Operations producing random values
(define (random modulus #!optional state)
- (let ((state (get-random-state state 'RANDOM)))
+ (let ((state (get-random-state state 'random)))
;; Kludge: an exact integer modulus means that result is an exact
;; integer. Otherwise, the result is a real number.
(cond ((int:integer? modulus)
(if (int:> modulus 0)
(%random-integer modulus state)
- (error:bad-range-argument modulus 'RANDOM)))
+ (error:bad-range-argument modulus 'random)))
((flo:flonum? modulus)
(if (flo:> modulus 0.)
(flo:* (flo:random-unit state) modulus)
- (error:bad-range-argument modulus 'RANDOM)))
+ (error:bad-range-argument modulus 'random)))
((real? modulus)
;; I can't think of the correct thing to do here. The old
;; code scaled a random element into the appropriate range,
;; know. -- cph
(error "Unsupported modulus:" modulus))
(else
- (error:wrong-type-argument modulus "real number" 'RANDOM)))))
+ (error:wrong-type-argument modulus "real number" 'random)))))
(define (flo:random-unit state)
;; Guarantee that (< 0 returned-value 1)
bytes))
(define (random-source-make-integers source)
- (guarantee-random-state source 'RANDOM-SOURCE-MAKE-INTEGERS)
+ (guarantee-random-state source 'random-source-make-integers)
(lambda (modulus)
(if (int:> modulus 0)
(%random-integer modulus source)
(error:bad-range-argument modulus #f))))
(define (random-source-make-reals source #!optional unit)
- (guarantee-random-state source 'RANDOM-SOURCE-MAKE-REALS)
+ (guarantee-random-state source 'random-source-make-reals)
(let ((unit
(if (default-object? unit)
.5
(if (not (and (real? unit) (< 0 unit 1)))
(error:wrong-type-argument unit
"real unit"
- 'RANDOM-SOURCE-MAKE-REALS))
+ 'random-source-make-reals))
unit))))
(if (flo:flonum? unit)
;; Ignore UNIT and return maximum precision.
(else (outer)))))))))
(simple-random-state))
(copy-random-state
- (get-random-state state 'MAKE-RANDOM-STATE))))
+ (get-random-state state 'make-random-state))))
(define (simple-random-state)
(initial-random-state
(define (random-source-pseudo-randomize! source i j)
source i j
- (error "Unimplemented procedure:" 'RANDOM-SOURCE-PSEUDO-RANDOMIZE!))
+ (error "Unimplemented procedure:" 'random-source-pseudo-randomize!))
(define (initial-random-state generate-random-seed)
;; The numbers returned by GENERATE-RANDOM-SEED are not critical.
\f
;;;; External representation of state
-(define-integrable ers:tag 'RANDOM-STATE-V1)
+(define-integrable ers:tag 'random-state-v1)
(define-integrable ers:length (fix:+ r 3))
(define (export-random-state state)
- (guarantee-random-state state 'EXPORT-RANDOM-STATE)
+ (guarantee-random-state state 'export-random-state)
(let ((v (make-vector ers:length)))
(vector-set! v 0 ers:tag)
(vector-set! v 1 (random-state-index state))
(lambda ()
(error:wrong-type-argument v
"external random state"
- 'IMPORT-RANDOM-STATE))))
+ 'import-random-state))))
(if (not (and (vector? v)
(fix:= (vector-length v) ers:length)
(eq? (vector-ref v 0) ers:tag)))
(lambda ()
(random-source-randomize! default-random-source)))
(named-structure/set-tag-description! random-state-tag
- (make-define-structure-type 'VECTOR
- 'RANDOM-STATE
- '#(INDEX BORROW VECTOR)
+ (make-define-structure-type 'vector
+ 'random-state
+ '#(index borrow vector)
'#(1 2 3)
(make-vector 3 (lambda () #f))
- (standard-unparser-method 'RANDOM-STATE #f)
+ (standard-unparser-method 'random-state #f)
random-state-tag
4)))
\ No newline at end of file
;;; permit code to be used for either symmetry:
(define-integrable (b->d left?)
- (if left? 'LEFT 'RIGHT))
+ (if left? 'left 'right))
(define-integrable (-d d)
- (if (eq? 'LEFT d) 'RIGHT 'LEFT))
+ (if (eq? 'left d) 'right 'left))
(define-integrable (get-link+ p d)
- (if (eq? 'LEFT d)
+ (if (eq? 'left d)
(node-left p)
(node-right p)))
(define-integrable (set-link+! p d l)
- (if (eq? 'LEFT d)
+ (if (eq? 'left d)
(set-node-left! p l)
(set-node-right! p l)))
(define-integrable (get-link- p d)
- (if (eq? 'RIGHT d)
+ (if (eq? 'right d)
(node-left p)
(node-right p)))
(define-integrable (set-link-! p d l)
- (if (eq? 'RIGHT d)
+ (if (eq? 'right d)
(set-node-left! p l)
(set-node-right! p l)))
(rotate+! tree x (-d d)))
\f
(define (rb-tree/insert! tree key datum)
- (guarantee-rb-tree tree 'RB-TREE/INSERT!)
+ (guarantee-rb-tree tree 'rb-tree/insert!)
(let ((key=? (tree-key=? tree))
(key<? (tree-key<? tree)))
(let loop ((x (tree-root tree)) (y #f) (d #f))
(lambda ()
(set-node-up! z y)
(cond ((not y) (set-tree-root! tree z))
- ((eq? 'LEFT d) (set-node-left! y z))
+ ((eq? 'left d) (set-node-left! y z))
(else (set-node-right! y z)))
- (set-node-color! z 'RED)
+ (set-node-color! z 'red)
(insert-fixup! tree z)))))
((key=? key (node-key x)) (set-node-datum! x datum))
- ((key<? key (node-key x)) (loop (node-left x) x 'LEFT))
- (else (loop (node-right x) x 'RIGHT))))))
+ ((key<? key (node-key x)) (loop (node-left x) x 'left))
+ (else (loop (node-right x) x 'right))))))
(define (insert-fixup! tree x)
;; Assumptions: X is red, and the only possible violation of the
;; tree properties is that (NODE-UP X) is also red.
(let loop ((x x))
(let ((u (node-up x)))
- (if (and u (eq? 'RED (node-color u)))
+ (if (and u (eq? 'red (node-color u)))
(let ((d (b->d (eq? u (node-left (node-up u))))))
(let ((y (get-link- (node-up u) d)))
- (if (and y (eq? 'RED (node-color y)))
+ (if (and y (eq? 'red (node-color y)))
;; case 1
(begin
- (set-node-color! u 'BLACK)
- (set-node-color! y 'BLACK)
- (set-node-color! (node-up u) 'RED)
+ (set-node-color! u 'black)
+ (set-node-color! y 'black)
+ (set-node-color! (node-up u) 'red)
(loop (node-up u)))
(let ((x
(if (eq? x (get-link- u d))
x)))
;; case 3
(let ((u (node-up x)))
- (set-node-color! u 'BLACK)
- (set-node-color! (node-up u) 'RED)
+ (set-node-color! u 'black)
+ (set-node-color! (node-up u) 'red)
(rotate-! tree (node-up u) d)))))))))
- (set-node-color! (tree-root tree) 'BLACK))
+ (set-node-color! (tree-root tree) 'black))
(define (alist->rb-tree alist key=? key<?)
;; Is there a more efficient way to do this?
tree))
\f
(define (rb-tree/delete! tree key)
- (guarantee-rb-tree tree 'RB-TREE/DELETE!)
+ (guarantee-rb-tree tree 'rb-tree/delete!)
(let ((key=? (tree-key=? tree))
(key<? (tree-key<? tree)))
(let loop ((x (tree-root tree)))
(cond ((not u) (set-tree-root! tree x))
((eq? z (node-left u)) (set-node-left! u x))
(else (set-node-right! u x)))
- (if (eq? 'BLACK (node-color z))
+ (if (eq? 'black (node-color z))
(delete-fixup! tree x u)))))))
(define (delete-fixup! tree x u)
(let loop ((x x) (u u))
(if (or (not u)
- (and x (eq? 'RED (node-color x))))
- (if x (set-node-color! x 'BLACK))
+ (and x (eq? 'red (node-color x))))
+ (if x (set-node-color! x 'black))
(let ((d (b->d (eq? x (node-left u)))))
(let ((w
(let ((w (get-link- u d)))
- (if (eq? 'RED (node-color w))
+ (if (eq? 'red (node-color w))
;; case 1
(begin
- (set-node-color! w 'BLACK)
- (set-node-color! u 'RED)
+ (set-node-color! w 'black)
+ (set-node-color! u 'red)
(rotate+! tree u d)
(get-link- u d))
w)))
(case-4
(lambda (w)
(set-node-color! w (node-color u))
- (set-node-color! u 'BLACK)
- (set-node-color! (get-link- w d) 'BLACK)
+ (set-node-color! u 'black)
+ (set-node-color! (get-link- w d) 'black)
(rotate+! tree u d)
- (set-node-color! (tree-root tree) 'BLACK))))
+ (set-node-color! (tree-root tree) 'black))))
(if (let ((n- (get-link- w d)))
(and n-
- (eq? 'RED (node-color n-))))
+ (eq? 'red (node-color n-))))
(case-4 w)
(let ((n+ (get-link+ w d)))
(if (or (not n+)
- (eq? 'BLACK (node-color n+)))
+ (eq? 'black (node-color n+)))
;; case 2
(begin
- (set-node-color! w 'RED)
+ (set-node-color! w 'red)
(loop u (node-up u)))
;; case 3
(begin
- (set-node-color! n+ 'BLACK)
- (set-node-color! w 'RED)
+ (set-node-color! n+ 'black)
+ (set-node-color! w 'red)
(rotate-! tree w d)
(case-4 (get-link- u d)))))))))))
\f
(define (rb-tree/lookup tree key default)
- (guarantee-rb-tree tree 'RB-TREE/LOOKUP)
+ (guarantee-rb-tree tree 'rb-tree/lookup)
(let ((key=? (tree-key=? tree))
(key<? (tree-key<? tree)))
(let loop ((x (tree-root tree)))
(else (loop (node-right x)))))))
(define (rb-tree/copy tree)
- (guarantee-rb-tree tree 'RB-TREE/COPY)
+ (guarantee-rb-tree tree 'rb-tree/copy)
(let ((result (make-rb-tree (tree-key=? tree) (tree-key<? tree))))
(set-tree-root!
result
result))
(define (rb-tree/height tree)
- (guarantee-rb-tree tree 'RB-TREE/HEIGHT)
+ (guarantee-rb-tree tree 'rb-tree/height)
(let loop ((node (tree-root tree)))
(if node
(+ 1 (max (loop (node-left node)) (loop (node-right node))))
0)))
(define (rb-tree/size tree)
- (guarantee-rb-tree tree 'RB-TREE/SIZE)
+ (guarantee-rb-tree tree 'rb-tree/size)
(let loop ((node (tree-root tree)))
(if node
(+ 1 (loop (node-left node)) (loop (node-right node)))
0)))
(define (rb-tree/empty? tree)
- (guarantee-rb-tree tree 'RB-TREE/EMPTY?)
+ (guarantee-rb-tree tree 'rb-tree/empty?)
(not (tree-root tree)))
\f
(define (rb-tree/equal? x y datum=?)
- (guarantee-rb-tree x 'RB-TREE/EQUAL?)
- (guarantee-rb-tree y 'RB-TREE/EQUAL?)
+ (guarantee-rb-tree x 'rb-tree/equal?)
+ (guarantee-rb-tree y 'rb-tree/equal?)
(let ((key=? (tree-key=? x)))
(and (eq? key=? (tree-key=? y))
(let loop ((nx (min-node x)) (ny (min-node y)))
(loop (next-node nx) (next-node ny))))))))
(define (rb-tree->alist tree)
- (guarantee-rb-tree tree 'RB-TREE->ALIST)
+ (guarantee-rb-tree tree 'rb-tree->alist)
(let ((node (min-node tree)))
(if node
(let ((result (list (cons (node-key node) (node-datum node)))))
'())))
(define (rb-tree/key-list tree)
- (guarantee-rb-tree tree 'RB-TREE/KEY-LIST)
+ (guarantee-rb-tree tree 'rb-tree/key-list)
(let ((node (min-node tree)))
(if node
(let ((result (list (node-key node))))
'())))
(define (rb-tree/datum-list tree)
- (guarantee-rb-tree tree 'RB-TREE/DATUM-LIST)
+ (guarantee-rb-tree tree 'rb-tree/datum-list)
(let ((node (min-node tree)))
(if node
(let ((result (list (node-datum node))))
'())))
\f
(define (rb-tree/min tree default)
- (guarantee-rb-tree tree 'RB-TREE/MIN)
+ (guarantee-rb-tree tree 'rb-tree/min)
(let ((node (min-node tree)))
(if node
(node-key node)
default)))
(define (rb-tree/min-datum tree default)
- (guarantee-rb-tree tree 'RB-TREE/MIN-DATUM)
+ (guarantee-rb-tree tree 'rb-tree/min-datum)
(let ((node (min-node tree)))
(if node
(node-datum node)
default)))
(define (rb-tree/min-pair tree)
- (guarantee-rb-tree tree 'RB-TREE/MIN-PAIR)
+ (guarantee-rb-tree tree 'rb-tree/min-pair)
(let ((node (min-node tree)))
(and node
(node-pair node))))
(define (rb-tree/delete-min! tree default)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN!)
+ (guarantee-rb-tree tree 'rb-tree/delete-min!)
(let ((node (min-node tree)))
(if node
(let ((key (node-key node)))
default)))
(define (rb-tree/delete-min-datum! tree default)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN-DATUM!)
+ (guarantee-rb-tree tree 'rb-tree/delete-min-datum!)
(let ((node (min-node tree)))
(if node
(let ((datum (node-datum node)))
default)))
(define (rb-tree/delete-min-pair! tree)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MIN-PAIR!)
+ (guarantee-rb-tree tree 'rb-tree/delete-min-pair!)
(let ((node (min-node tree)))
(and node
(let ((pair (node-pair node)))
pair))))
\f
(define (rb-tree/max tree default)
- (guarantee-rb-tree tree 'RB-TREE/MAX)
+ (guarantee-rb-tree tree 'rb-tree/max)
(let ((node (max-node tree)))
(if node
(node-key node)
default)))
(define (rb-tree/max-datum tree default)
- (guarantee-rb-tree tree 'RB-TREE/MAX-DATUM)
+ (guarantee-rb-tree tree 'rb-tree/max-datum)
(let ((node (max-node tree)))
(if node
(node-datum node)
default)))
(define (rb-tree/max-pair tree)
- (guarantee-rb-tree tree 'RB-TREE/MAX-PAIR)
+ (guarantee-rb-tree tree 'rb-tree/max-pair)
(let ((node (max-node tree)))
(and node
(node-pair node))))
(define (rb-tree/delete-max! tree default)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX!)
+ (guarantee-rb-tree tree 'rb-tree/delete-max!)
(let ((node (max-node tree)))
(if node
(let ((key (node-key node)))
default)))
(define (rb-tree/delete-max-datum! tree default)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX-DATUM!)
+ (guarantee-rb-tree tree 'rb-tree/delete-max-datum!)
(let ((node (max-node tree)))
(if node
(let ((datum (node-datum node)))
default)))
(define (rb-tree/delete-max-pair! tree)
- (guarantee-rb-tree tree 'RB-TREE/DELETE-MAX-PAIR!)
+ (guarantee-rb-tree tree 'rb-tree/delete-max-pair!)
(let ((node (max-node tree)))
(and node
(let ((pair (node-pair node)))
(if (not (vector-ref seen? i))
(let ((init (vector-ref inits i)))
(and init (vector-set! v (vector-ref indexes i) (init)))))))
- (if (eq? (structure-type/physical-type type) 'LIST)
+ (if (eq? (structure-type/physical-type type) 'list)
(do ((i (fix:- len 1) (fix:- i 1))
(list '() (cons (vector-ref v i) list)))
((not (fix:>= i 0)) list))
(define (initialize-conditions!)
(set! condition-type:slot-error
- (make-condition-type 'SLOT-ERROR condition-type:cell-error
+ (make-condition-type 'slot-error condition-type:cell-error
'()
(lambda (condition port)
(write-string "Anonymous error for slot " port)
- (write (access-condition condition 'LOCATION) port)
+ (write (access-condition condition 'location) port)
(write-string "." port))))
(set! condition-type:uninitialized-slot
- (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error
- '(RECORD)
+ (make-condition-type 'uninitialized-slot condition-type:slot-error
+ '(record)
(lambda (condition port)
(write-string "Attempt to reference slot " port)
- (write (access-condition condition 'LOCATION) port)
+ (write (access-condition condition 'location) port)
(write-string " in record " port)
- (write (access-condition condition 'RECORD) port)
+ (write (access-condition condition 'record) port)
(write-string " failed because the slot is not initialized."
port))))
(set! condition-type:no-such-slot
- (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error
- '(RECORD-TYPE)
+ (make-condition-type 'no-such-slot condition-type:slot-error
+ '(record-type)
(lambda (condition port)
(write-string "No slot named " port)
- (write (access-condition condition 'LOCATION) port)
+ (write (access-condition condition 'location) port)
(write-string " in records of type " port)
- (write (access-condition condition 'RECORD-TYPE) port)
+ (write (access-condition condition 'record-type) port)
(write-string "." port))))
(set! error:uninitialized-slot
(let ((signal
(condition-signaller condition-type:uninitialized-slot
- '(RECORD LOCATION)
+ '(record location)
standard-error-handler)))
(lambda (record index)
(let* ((location (%record-field-name record index))
(set! error:no-such-slot
(let ((signal
(condition-signaller condition-type:no-such-slot
- '(RECORD-TYPE LOCATION)
+ '(record-type location)
standard-error-handler)))
(lambda (record-type name)
(call-with-current-continuation
console-i/o-port
user-initial-environment
#f
- `((SET-DEFAULT-DIRECTORY
+ `((set-default-directory
,top-level-repl/set-default-directory))
user-initial-prompt)
(cmdl-message/append
(define (make-cmdl parent port driver state operations)
(if (not (or (not parent) (cmdl? parent)))
- (error:wrong-type-argument parent "cmdl" 'MAKE-CMDL))
+ (error:wrong-type-argument parent "cmdl" 'make-cmdl))
(if (not (or parent port))
- (error:bad-range-argument port 'MAKE-CMDL))
+ (error:bad-range-argument port 'make-cmdl))
(%make-cmdl (if parent (+ (cmdl/level parent) 1) 1)
parent
(or port (and parent (cmdl/child-port parent)))
driver
state
- (parse-operations-list operations 'MAKE-CMDL)
+ (parse-operations-list operations 'make-cmdl)
(make-1d-table)))
(define (cmdl/child-port cmdl)
- (or (let ((operation (cmdl/local-operation cmdl 'CHILD-PORT)))
+ (or (let ((operation (cmdl/local-operation cmdl 'child-port)))
(and operation
(operation cmdl)))
(cmdl/port cmdl)))
cmdl)))
(define (cmdl/set-default-directory cmdl pathname)
- (let ((operation (cmdl/local-operation cmdl 'SET-DEFAULT-DIRECTORY)))
+ (let ((operation (cmdl/local-operation cmdl 'set-default-directory)))
(if operation
(operation cmdl pathname)))
(port/set-default-directory (cmdl/port cmdl) pathname))
(cond ((and owner (not (eq? thread owner)))
(signal-thread-event owner
(let ((signaller
- (or (cmdl/local-operation cmdl 'START-NON-OWNED)
+ (or (cmdl/local-operation cmdl 'start-non-owned)
(lambda (cmdl thread)
cmdl
(error "Non-owner thread can't start CMDL:"
(stop-current-thread))
((let ((parent (cmdl/parent cmdl)))
(and parent
- (cmdl/local-operation parent 'START-CHILD)))
+ (cmdl/local-operation parent 'start-child)))
=> (lambda (operation) (operation cmdl thunk)))
(else
(with-thread-mutex-locked mutex thunk)))))))
(define (bind-abort-restart cmdl thunk)
(call-with-current-continuation
(lambda (continuation)
- (with-restart 'ABORT
+ (with-restart 'abort
(string-append "Return to "
(if (repl? cmdl)
"read-eval-print"
(define ((cmdl-message/strings . strings) cmdl)
(let ((port (cmdl/port cmdl)))
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(for-each (lambda (string)
(fresh-line port)
(define ((cmdl-message/active actor) cmdl)
(let ((port (cmdl/port cmdl)))
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(actor port)))))
;;;; Interrupts
(define (cmdl-interrupt/breakpoint)
- ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/BREAKPOINT)
+ ((or (cmdl/operation (nearest-cmdl) 'interrupt/breakpoint)
breakpoint)))
(define (cmdl-interrupt/abort-nearest)
- ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-NEAREST)
+ ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-nearest)
abort->nearest)))
(define (cmdl-interrupt/abort-previous)
- ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-PREVIOUS)
+ ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-previous)
abort->previous)))
(define (cmdl-interrupt/abort-top-level)
- ((or (cmdl/operation (nearest-cmdl) 'INTERRUPT/ABORT-TOP-LEVEL)
+ ((or (cmdl/operation (nearest-cmdl) 'interrupt/abort-top-level)
abort->top-level)))
(define (abort->nearest #!optional message)
- (invoke-abort (let ((restart (find-restart 'ABORT)))
+ (invoke-abort (let ((restart (find-restart 'abort)))
(if (not restart)
- (error:no-such-restart 'ABORT))
+ (error:no-such-restart 'abort))
restart)
(if (default-object? message) "Abort!" message)))
(define (abort->previous #!optional message)
- (invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts))))
- (let ((next (find-restarts 'ABORT (cdr restarts))))
+ (invoke-abort (let ((restarts (find-restarts 'abort (bound-restarts))))
+ (let ((next (find-restarts 'abort (cdr restarts))))
(cond ((pair? next) (car next))
((pair? restarts) (car restarts))
- (else (error:no-such-restart 'ABORT)))))
+ (else (error:no-such-restart 'abort)))))
(if (default-object? message) "Up!" message)))
(define (abort->top-level #!optional message)
- (invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts))))
- (let ((next (find-restarts 'ABORT (cdr restarts))))
+ (invoke-abort (let loop ((restarts (find-restarts 'abort (bound-restarts))))
+ (let ((next (find-restarts 'abort (cdr restarts))))
(cond ((pair? next) (loop next))
((pair? restarts) (car restarts))
- (else (error:no-such-restart 'ABORT)))))
+ (else (error:no-such-restart 'abort)))))
(if (default-object? message) "Quit!" message)))
(define (find-restarts name restarts)
(effector))))
(define cmdl-abort-restart-tag
- (list 'CMDL-ABORT-RESTART-TAG))
+ (list 'cmdl-abort-restart-tag))
\f
;;;; REP Loops
(let ((inherit
(let ((repl (and parent (skip-non-repls parent))))
(lambda (argument default name check-arg)
- (if (eq? 'INHERIT argument)
+ (if (eq? 'inherit argument)
(begin
(if (not repl)
(error "Can't inherit -- no REPL ancestor:"
name))
(default repl))
- (check-arg argument 'MAKE-REPL))))))
+ (check-arg argument 'make-repl))))))
(make-repl-state
- (inherit (if (default-object? prompt) 'INHERIT prompt)
+ (inherit (if (default-object? prompt) 'inherit prompt)
repl/prompt
- 'PROMPT
+ 'prompt
(lambda (object procedure)
(if (not (string? object))
(error:wrong-type-argument object
object))
(inherit environment
repl/environment
- 'ENVIRONMENT
+ 'environment
->environment)
(if (default-object? condition) #f condition)))
(append (if (default-object? operations) '() operations)
default-repl-operations)))
(define default-repl-operations
- `((START-CHILD ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk)))
- (START-NON-OWNED
+ `((start-child ,(lambda (cmdl thunk) cmdl (with-history-disabled thunk)))
+ (start-non-owned
,(lambda (repl thread)
(let ((condition (repl/condition repl)))
(if condition
environment
(if (default-object? condition) #f condition)
(if (default-object? operations) '() operations)
- (if (default-object? prompt) 'INHERIT prompt))))
+ (if (default-object? prompt) 'inherit prompt))))
(define (repl-driver repl)
(let ((condition (repl/condition repl)))
(if (and condition (condition/error? condition))
- (cond ((cmdl/operation repl 'ERROR-DECISION)
+ (cond ((cmdl/operation repl 'error-decision)
=> (lambda (operation)
(operation repl condition)))
(hook/error-decision
(enqueue! (repl/input-queue (nearest-repl)) procedure))
\f
(define (repl-read #!optional environment repl)
- (receive (environment repl) (optional-er environment repl 'REPL-READ)
+ (receive (environment repl) (optional-er environment repl 'repl-read)
(hook/repl-read environment repl)))
(define hook/repl-read)
(define (default/repl-read environment repl)
- (prompt-for-command-expression (cons 'STANDARD (repl/prompt repl))
+ (prompt-for-command-expression (cons 'standard (repl/prompt repl))
(cmdl/port repl)
environment))
(define (repl-eval s-expression #!optional environment repl)
- (receive (environment repl) (optional-er environment repl 'REPL-EVAL)
+ (receive (environment repl) (optional-er environment repl 'repl-eval)
(%repl-eval s-expression environment repl)))
(define (%repl-eval s-expression environment repl)
(define hook/repl-eval)
(define (default/repl-eval s-expression environment repl)
(if (and (pair? s-expression)
- (eq? 'UNQUOTE (car s-expression)))
+ (eq? 'unquote (car s-expression)))
(let ((env (->environment '(user))))
(%repl-scode-eval (syntax (cadr s-expression) env) env repl))
(%repl-scode-eval (syntax s-expression environment) environment repl)))
(define (repl-scode-eval scode #!optional environment repl)
- (receive (environment repl) (optional-er environment repl 'REPL-SCODE-EVAL)
+ (receive (environment repl) (optional-er environment repl 'repl-scode-eval)
(%repl-scode-eval scode environment repl)))
(define (%repl-scode-eval scode environment repl)
repl))
(define (repl-write value s-expression #!optional environment repl)
- (receive (environment repl) (optional-er environment repl 'REPL-WRITE)
+ (receive (environment repl) (optional-er environment repl 'repl-write)
(hook/repl-write value s-expression environment repl)))
(define hook/repl-write)
environment))
(define (repl-eval/write s-expression #!optional environment repl)
- (receive (environment repl) (optional-er environment repl 'REPL-EVAL/WRITE)
+ (receive (environment repl) (optional-er environment repl 'repl-eval/write)
(%repl-eval/write s-expression environment repl)))
(define (%repl-eval/write s-expression environment repl)
(if (not (and parent
(repl? parent)
(eq? (repl/environment parent) environment)))
- (let ((operation (cmdl/operation repl 'SET-DEFAULT-ENVIRONMENT)))
+ (let ((operation (cmdl/operation repl 'set-default-environment)))
(if operation
(operation repl environment)
(hook/set-default-environment repl environment))))))
(define hook/set-default-environment)
(define (default/set-default-environment port environment)
(let ((port (cmdl/port port)))
- (with-output-port-terminal-mode port 'COOKED
+ (with-output-port-terminal-mode port 'cooked
(lambda ()
(if (not (interpreter-environment? environment))
(begin
(loop))))))
(begin
(if (not (exact-integer? n))
- (error:wrong-type-argument n "exact integer" 'RESTART))
+ (error:wrong-type-argument n "exact integer" 'restart))
(if (not (<= 1 n n-restarts))
- (error:bad-range-argument n 'RESTART))
+ (error:bad-range-argument n 'restart))
n))))
condition)))))
\f
(define (repl-history/read history n)
(if (not (and (exact-nonnegative-integer? n)
(< n (repl-history/size history))))
- (error:wrong-type-argument n "history index" 'REPL-HISTORY/READ))
+ (error:wrong-type-argument n "history index" 'repl-history/read))
(list-ref (repl-history/elements history)
(- (- (repl-history/size history) 1) n)))
\f
environment))))
(define (ge environment)
- (let ((environment (->environment environment 'GE)))
+ (let ((environment (->environment environment 'ge)))
(set-repl/environment! (nearest-repl) environment)
(set-load-environment! environment)
environment))
(define (->environment object #!optional caller)
- (let ((caller (if (default-object? caller) '->ENVIRONMENT caller)))
+ (let ((caller (if (default-object? caller) '->environment caller)))
(cond ((environment? object) object)
((package? object) (package/environment object))
((procedure? object) (procedure-environment object))
(repl/start (push-repl environment #f '() prompt) message))
(define (ve environment)
- (read-eval-print (->environment environment 'VE) #f 'INHERIT))
+ (read-eval-print (->environment environment 've) #f 'inherit))
(define (proceed #!optional value)
(if (default-object? value)
;;;; Breakpoints
(define (bkpt datum . arguments)
- (apply breakpoint-procedure 'CONTINUATION-ENVIRONMENT datum arguments))
+ (apply breakpoint-procedure 'continuation-environment datum arguments))
(define (breakpoint-procedure environment datum . arguments)
(signal-breakpoint-1 #f
(call-with-current-continuation
(lambda (restart-continuation)
(let ((continuation (or continuation restart-continuation)))
- (with-restart 'CONTINUE reporter
+ (with-restart 'continue reporter
(lambda () (restart-continuation unspecific))
values
(lambda ()
(define (get-breakpoint-environment continuation environment message)
(let ((environment
- (if (eq? 'CONTINUATION-ENVIRONMENT environment)
+ (if (eq? 'continuation-environment environment)
(continuation/first-subproblem-environment continuation)
environment)))
- (if (eq? 'NO-ENVIRONMENT environment)
+ (if (eq? 'no-environment environment)
(values (nearest-repl/environment)
(cmdl-message/append
message
(lambda (expression environment subexpression)
expression subexpression
(if (debugging-info/undefined-environment? environment)
- 'NO-ENVIRONMENT
+ 'no-environment
environment)))
- 'NO-ENVIRONMENT)))
+ 'no-environment)))
\f
(define condition-type:breakpoint)
(define condition/breakpoint?)
(define (initialize-breakpoint-condition!)
(set! condition-type:breakpoint
- (make-condition-type 'BREAKPOINT #f '(ENVIRONMENT MESSAGE PROMPT)
+ (make-condition-type 'breakpoint #f '(environment message prompt)
(lambda (condition port)
condition
(write-string "Breakpoint." port))))
(set! condition/breakpoint?
(condition-predicate condition-type:breakpoint))
(set! breakpoint/environment
- (condition-accessor condition-type:breakpoint 'ENVIRONMENT))
+ (condition-accessor condition-type:breakpoint 'environment))
(set! breakpoint/message
- (condition-accessor condition-type:breakpoint 'MESSAGE))
+ (condition-accessor condition-type:breakpoint 'message))
(set! breakpoint/prompt
- (condition-accessor condition-type:breakpoint 'PROMPT))
+ (condition-accessor condition-type:breakpoint 'prompt))
(set! %signal-breakpoint
(let ((make-condition
(condition-constructor condition-type:breakpoint
- '(ENVIRONMENT MESSAGE PROMPT))))
+ '(environment message prompt))))
(lambda (continuation environment message prompt)
(let ((condition
(make-condition continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
environment
message
prompt)))
(and (fix:= 1 (length (cdr rexp)))
(rexp? (cadr rexp))))))
(case (car rexp)
- ((ALTERNATIVES SEQUENCE)
+ ((alternatives sequence)
(every rexp? (cdr rexp)))
- ((GROUP OPTIONAL * +)
+ ((group optional * +)
(and (one-arg)
(not (or (and (string? rexp)
(string-null? rexp))
(and (pair? rexp)
(memq (car rexp) boundary-rexp-types))))))
- ((CASE-FOLD)
+ ((case-fold)
(and (fix:= 1 (length (cdr rexp)))
(string? (cadr exp))))
- ((ANY-CHAR LINE-START LINE-END STRING-START STRING-END
- WORD-EDGE NOT-WORD-EDGE WORD-START WORD-END
- WORD-CHAR NOT-WORD-CHAR)
+ ((any-char line-start line-end string-start string-end
+ word-edge not-word-edge word-start word-end
+ word-char not-word-char)
(null? (cdr rexp)))
- ((SYNTAX-CHAR NOT-SYNTAX-CHAR)
+ ((syntax-char not-syntax-char)
(and (one-arg)
(assq (cadr rexp) syntax-type-alist)))
(else #f))))))
(define boundary-rexp-types
- '(LINE-START LINE-END STRING-START STRING-END WORD-EDGE NOT-WORD-EDGE
- WORD-START WORD-END))
+ '(line-start line-end string-start string-end word-edge not-word-edge
+ word-start word-end))
(define syntax-type-alist
- '((WHITESPACE . " ")
- (PUNCTUATION . ".")
- (WORD . "w")
- (SYMBOL . "_")
- (OPEN . "(")
- (CLOSE . ")")
- (QUOTE . "\'")
- (STRING-DELIMITER . "\"")
- (MATH-DELIMITER . "$")
- (ESCAPE . "\\")
- (CHAR-QUOTE . "/")
- (COMMENT-START . "<")
- (COMMENT-END . ">")))
+ '((whitespace . " ")
+ (punctuation . ".")
+ (word . "w")
+ (symbol . "_")
+ (open . "(")
+ (close . ")")
+ (quote . "\'")
+ (string-delimiter . "\"")
+ (math-delimiter . "$")
+ (escape . "\\")
+ (char-quote . "/")
+ (comment-start . "<")
+ (comment-end . ">")))
\f
(define (rexp-alternatives . rexps)
- `(ALTERNATIVES ,@rexps))
+ `(alternatives ,@rexps))
(define (rexp-sequence . rexps)
(let ((rexps (simplify-sequence-args rexps)))
(if (pair? rexps)
(if (pair? (cdr rexps))
- `(SEQUENCE ,@rexps)
+ `(sequence ,@rexps)
(car rexps))
"")))
(append-map (lambda (rexp)
(cond ((and (string? rexp) (string-null? rexp))
'())
- ((and (pair? rexp) (eq? 'SEQUENCE (car rexp)))
+ ((and (pair? rexp) (eq? 'sequence (car rexp)))
(cdr rexp))
- ((and (pair? rexp) (eq? 'ALTERNATIVES (car rexp)))
- (list `(GROUP ,rexp)))
+ ((and (pair? rexp) (eq? 'alternatives (car rexp)))
+ (list `(group ,rexp)))
(else
(list rexp))))
rexps))
(define (rexp-group . rexps)
(let ((rexp (apply rexp-sequence rexps)))
- (if (and (pair? rexp) (eq? (car rexp) 'GROUP))
+ (if (and (pair? rexp) (eq? (car rexp) 'group))
rexp
- `(GROUP ,rexp))))
+ `(group ,rexp))))
(define (rexp-optional . rexps)
- `(OPTIONAL ,(rexp-groupify (apply rexp-sequence rexps))))
+ `(optional ,(rexp-groupify (apply rexp-sequence rexps))))
(define (rexp* . rexps)
`(* ,(rexp-groupify (apply rexp-sequence rexps))))
`(+ ,(rexp-groupify (apply rexp-sequence rexps))))
(define (rexp-groupify rexp)
- (let ((group (lambda () `(GROUP ,rexp)))
+ (let ((group (lambda () `(group ,rexp)))
(no-group (lambda () (error "Expression can't be grouped:" rexp))))
(cond ((string? rexp)
(case (string-length rexp)
((pair? rexp)
(cond ((memq (car rexp) boundary-rexp-types)
(no-group))
- ((memq (car rexp) '(ALTERNATIVES SEQUENCE OPTIONAL * +))
+ ((memq (car rexp) '(alternatives sequence optional * +))
(group))
(else rexp)))
(else rexp))))
-(define (rexp-any-char) `(ANY-CHAR))
-(define (rexp-line-start) `(LINE-START))
-(define (rexp-line-end) `(LINE-END))
-(define (rexp-string-start) `(STRING-START))
-(define (rexp-string-end) `(STRING-END))
-(define (rexp-word-edge) `(WORD-EDGE))
-(define (rexp-not-word-edge) `(NOT-WORD-EDGE))
-(define (rexp-word-start) `(WORD-START))
-(define (rexp-word-end) `(WORD-END))
-(define (rexp-word-char) `(WORD-CHAR))
-(define (rexp-not-word-char) `(NOT-WORD-CHAR))
-(define (rexp-syntax-char type) `(SYNTAX-CHAR ,type))
-(define (rexp-not-syntax-char type) `(NOT-SYNTAX-CHAR ,type))
+(define (rexp-any-char) `(any-char))
+(define (rexp-line-start) `(line-start))
+(define (rexp-line-end) `(line-end))
+(define (rexp-string-start) `(string-start))
+(define (rexp-string-end) `(string-end))
+(define (rexp-word-edge) `(word-edge))
+(define (rexp-not-word-edge) `(not-word-edge))
+(define (rexp-word-start) `(word-start))
+(define (rexp-word-end) `(word-end))
+(define (rexp-word-char) `(word-char))
+(define (rexp-not-word-char) `(not-word-char))
+(define (rexp-syntax-char type) `(syntax-char ,type))
+(define (rexp-not-syntax-char type) `(not-syntax-char ,type))
(define (rexp-case-fold rexp)
(cond ((or (string? rexp) (char-set? rexp))
- `(CASE-FOLD ,rexp))
+ `(case-fold ,rexp))
((and (pair? rexp)
- (memq (car rexp) '(ALTERNATIVES SEQUENCE GROUP OPTIONAL * +))
+ (memq (car rexp) '(alternatives sequence group optional * +))
(list? (cdr rexp)))
(cons (car rexp)
(map rexp-case-fold (cdr rexp))))
(cdr entry)
(lose))))))
(case (car rexp)
- ((ALTERNATIVES)
+ ((alternatives)
(decorated-string-append "" "\\|" "" (rexp-args)))
- ((SEQUENCE) (apply string-append (rexp-args)))
- ((GROUP) (string-append "\\(" (rexp-arg) "\\)"))
- ((OPTIONAL) (string-append (rexp-arg) "?"))
+ ((sequence) (apply string-append (rexp-args)))
+ ((group) (string-append "\\(" (rexp-arg) "\\)"))
+ ((optional) (string-append (rexp-arg) "?"))
((*) (string-append (rexp-arg) "*"))
((+) (string-append (rexp-arg) "+"))
- ((CASE-FOLD)
+ ((case-fold)
(rexp->regexp
(let ((arg (one-arg)))
(cond ((string? arg) (case-fold-string arg))
((char-set? arg) (case-fold-char-set arg))
(else (lose))))))
- ((ANY-CHAR) ".")
- ((LINE-START) "^")
- ((LINE-END) "$")
- ((STRING-START) "\\`")
- ((STRING-END) "\\'")
- ((WORD-EDGE) "\\b")
- ((NOT-WORD-EDGE) "\\B")
- ((WORD-START) "\\<")
- ((WORD-END) "\\>")
- ((WORD-CHAR) "\\w")
- ((NOT-WORD-CHAR) "\\W")
- ((SYNTAX-CHAR) (string-append "\\s" (syntax-type)))
- ((NOT-SYNTAX-CHAR) (string-append "\\S" (syntax-type)))
+ ((any-char) ".")
+ ((line-start) "^")
+ ((line-end) "$")
+ ((string-start) "\\`")
+ ((string-end) "\\'")
+ ((word-edge) "\\b")
+ ((not-word-edge) "\\B")
+ ((word-start) "\\<")
+ ((word-end) "\\>")
+ ((word-char) "\\w")
+ ((not-word-char) "\\W")
+ ((syntax-char) (string-append "\\s" (syntax-type)))
+ ((not-syntax-char) (string-append "\\S" (syntax-type)))
(else (lose))))))
(else (lose)))))
\f
(apply char-set chars*))))
(define (rexp-n*m n m . rexps)
- (guarantee exact-nonnegative-integer? n 'REXP-N*M)
- (guarantee exact-nonnegative-integer? m 'REXP-N*M)
+ (guarantee exact-nonnegative-integer? n 'rexp-n*m)
+ (guarantee exact-nonnegative-integer? m 'rexp-n*m)
(if (not (<= n m))
- (error:bad-range-argument m 'REXP-N*M))
+ (error:bad-range-argument m 'rexp-n*m))
(let ((rexp (apply rexp-sequence rexps)))
(let loop ((i 1))
(cond ((<= i n)
(apply rexp-n*m 0 n rexps))
(define (rexp-n* n . rexps)
- (guarantee exact-nonnegative-integer? n 'REXP-N*)
+ (guarantee exact-nonnegative-integer? n 'rexp-n*)
(let ((rexp (apply rexp-sequence rexps)))
(if (= n 0)
(rexp* rexp)
#t))))
(define (first-rfc2822-header name headers)
- (guarantee-list-of rfc2822-header? headers 'FIRST-RFC2822-HEADER)
+ (guarantee-list-of rfc2822-header? headers 'first-rfc2822-header)
(find (lambda (header)
(eq? (rfc2822-header-name header) name))
headers))
(define (all-rfc2822-headers name headers)
- (guarantee-list-of rfc2822-header? headers 'ALL-RFC2822-HEADERS)
+ (guarantee-list-of rfc2822-header? headers 'all-rfc2822-headers)
(filter (lambda (header)
(eq? (rfc2822-header-name header) name))
headers))
(write-rfc2822-headers headers port))))
(define (write-rfc2822-headers headers port)
- (guarantee-list-of rfc2822-header? headers 'WRITE-RFC2822-HEADERS)
+ (guarantee-list-of rfc2822-header? headers 'write-rfc2822-headers)
(for-each (lambda (header)
(write-header header port))
headers)
((char-wsp? (string-ref line 0))
(parse-error port
"Unmatched continuation line:"
- 'READ-RFC2822-FOLDED-LINE))
+ 'read-rfc2822-folded-line))
(else
(call-with-output-string
(lambda (out)
(if (eof-object? char)
(parse-error port
"Premature EOF:"
- 'READ-RFC2822-FOLDED-LINE))
+ 'read-rfc2822-folded-line))
(char-wsp? char))
(begin
(write-char #\space out)
(char-set-difference char-set:rfc2822-text
(char-set #\tab #\space #\delete #\\ #\")))
(set! condition-type:rfc2822-parse-error
- (make-condition-type 'RFC2822-PARSE-ERROR
+ (make-condition-type 'rfc2822-parse-error
condition-type:port-error
- '(MESSAGE IRRITANTS)
+ '(message irritants)
(lambda (condition port)
(write-string "Error while parsing RFC 2822 headers: " port)
- (format-error-message (access-condition condition 'MESSAGE)
- (access-condition condition 'IRRITANTS)
+ (format-error-message (access-condition condition 'message)
+ (access-condition condition 'irritants)
port))))
(set! parse-error
(let ((signal
(condition-signaller condition-type:rfc2822-parse-error
- '(PORT MESSAGE IRRITANTS)
+ '(port message irritants)
standard-error-handler)))
(lambda (port message . irritants)
(signal port message irritants))))
(((ucode-primitive dump-band)
restart
(string-for-primitive filename)))
- (with-simple-restart 'RETRY "Try again."
+ (with-simple-restart 'retry "Try again."
(lambda ()
(error "Disk save failed:" filename))))
(continuation
(let ((port
(if (default-object? port)
(current-output-port)
- (guarantee textual-output-port? port 'IDENTIFY-WORLD))))
+ (guarantee textual-output-port? port 'identify-world))))
(write-mit-scheme-copyright port #!default #!default #t)
(newline port)
(write-mit-scheme-license port #!default #t)
(ucode-type sequence))
(define null-sequence
- '(NULL-SEQUENCE))
+ '(null-sequence))
(define (cons-sequence action seq)
(if (eq? seq null-sequence)
((scan-loop expression receiver) '() '() null-sequence))
(define (scan-loop expression receiver)
- (cond ((scode-open-block? expression) ; must come before SCODE-SEQUENCE? clause
+ (cond ((scode-open-block? expression) ;must come before SCODE-SEQUENCE? clause
(scan-loop
(%open-block-actions expression)
(lambda (names declarations body)
(receive (names* body*) (unscan-loop names body)
(if (not (null? names*))
(error "Extraneous auxiliaries -- get a wizard"
- 'UNSCAN-DEFINES
+ 'unscan-defines
names*))
(if (null? declarations)
(->namestring (merge-pathnames filename))))))
(and n
(let ((types
- '#(REGULAR
- DIRECTORY
- UNIX-SYMBOLIC-LINK
- UNIX-CHARACTER-DEVICE
- UNIX-BLOCK-DEVICE
- UNIX-NAMED-PIPE
- UNIX-SOCKET
- UNKNOWN
- WIN32-NAMED-PIPE)))
+ '#(regular
+ directory
+ unix-symbolic-link
+ unix-character-device
+ unix-block-device
+ unix-named-pipe
+ unix-socket
+ unknown
+ win32-named-pipe)))
(if (fix:< n (vector-length types))
(vector-ref types n)
- 'UNKNOWN))))))))
+ 'unknown))))))))
(set! file-type-direct
(make-file-type (ucode-primitive file-type-direct 1)))
(set! file-type-indirect
(make-file-type (ucode-primitive file-type-indirect 1))))
(define (file-regular? filename)
- (eq? 'REGULAR (file-type-indirect filename)))
+ (eq? 'regular (file-type-indirect filename)))
(define (file-directory? filename)
- (eq? 'DIRECTORY (file-type-indirect filename)))
+ (eq? 'directory (file-type-indirect filename)))
(define (file-symbolic-link? filename)
((ucode-primitive file-symlink? 1)
(string->mime-type string)))))))
(define (associate-pathname-type-with-mime-type type mime-type)
- (guarantee string? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
- (guarantee mime-type? mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
+ (guarantee string? type 'associate-pathname-type-with-mime-type)
+ (guarantee mime-type? mime-type 'associate-pathname-type-with-mime-type)
(hash-table/put! local-type-map type mime-type))
(define (disassociate-pathname-type-from-mime-type type)
- (guarantee string? type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE)
- (hash-table/put! local-type-map type 'DISASSOCIATED))
+ (guarantee string? type 'disassociate-pathname-type-from-mime-type)
+ (hash-table/put! local-type-map type 'disassociated))
(define-record-type <mime-type>
(%%make-mime-type top-level subtype)
(subtype mime-type/subtype))
(define (make-mime-type top-level subtype)
- (guarantee mime-token? top-level 'MAKE-MIME-TYPE)
- (guarantee mime-token? subtype 'MAKE-MIME-TYPE)
+ (guarantee mime-token? top-level 'make-mime-type)
+ (guarantee mime-token? subtype 'make-mime-type)
(%make-mime-type top-level subtype))
(define (%make-mime-type top-level subtype)
new)))))
(define top-level-mime-types
- '#(TEXT IMAGE AUDIO VIDEO APPLICATION MULTIPART MESSAGE))
+ '#(text image audio video application multipart message))
(define-unparser-method mime-type?
- (standard-unparser-method 'MIME-TYPE
+ (standard-unparser-method 'mime-type
(lambda (mime-type port)
(write-char #\space port)
(write-string (mime-type->string mime-type) port))))
(string->char-set "()<>@,;:\\\"/[]?=")))
(set! local-type-map (make-string-hash-table))
(associate-pathname-type-with-mime-type "scm"
- (make-mime-type 'TEXT 'X-SCHEME))
+ (make-mime-type 'text 'x-scheme))
unspecific)
\f
(define (mime-type->string mime-type)
(write-mime-type mime-type port))))
(define (write-mime-type mime-type port)
- (guarantee mime-type? mime-type 'WRITE-MIME-TYPE)
+ (guarantee mime-type? mime-type 'write-mime-type)
(write-string (symbol->string (mime-type/top-level mime-type)) port)
(write-string "/" port)
(write-string (symbol->string (mime-type/subtype mime-type)) port))
(define (string->mime-type string #!optional start end)
(vector-ref (or (*parse-string parser:mime-type string start end)
- (error:not-a mime-type-string? string 'STRING->MIME-TYPE))
+ (error:not-a mime-type-string? string 'string->mime-type))
0))
(define (mime-type-string? object)
(define (bytevector-u8-xor! bv i x)
;;(declare (no-type-checks) (no-range-checks))
- (guarantee bytevector? bv 'BYTEVECTOR-U8-XOR!)
- (guarantee index-fixnum? i 'BYTEVECTOR-U8-XOR!)
+ (guarantee bytevector? bv 'bytevector-u8-xor!)
+ (guarantee index-fixnum? i 'bytevector-u8-xor!)
(if (not (fix:< i (bytevector-length bv)))
- (error:bad-range-argument i 'BYTEVECTOR-U8-XOR!))
- (guarantee u8? x 'BYTEVECTOR-U8-XOR)
+ (error:bad-range-argument i 'bytevector-u8-xor!))
+ (guarantee u8? x 'bytevector-u8-xor)
(bytevector-u8-set! bv i (fix:xor x (bytevector-u8-ref bv i))))
(define (bytevector-xor! t ts f fs n)
;;(declare (no-type-checks) (no-range-checks))
- (guarantee bytevector? f 'BYTEVECTOR-XOR!)
- (guarantee bytevector? t 'BYTEVECTOR-XOR!)
- (guarantee index-fixnum? ts 'BYTEVECTOR-XOR!)
- (guarantee index-fixnum? fs 'BYTEVECTOR-XOR!)
+ (guarantee bytevector? f 'bytevector-xor!)
+ (guarantee bytevector? t 'bytevector-xor!)
+ (guarantee index-fixnum? ts 'bytevector-xor!)
+ (guarantee index-fixnum? fs 'bytevector-xor!)
(if (not (fix:<= n (fix:- (bytevector-length t) ts)))
- (error:bad-range-argument ts 'BYTEVECTOR-XOR!))
+ (error:bad-range-argument ts 'bytevector-xor!))
(if (not (fix:<= n (fix:- (bytevector-length f) fs)))
- (error:bad-range-argument fs 'BYTEVECTOR-XOR!))
+ (error:bad-range-argument fs 'bytevector-xor!))
(do ((i 0 (fix:+ i 1))) ((fix:>= i n))
(let ((ti (bytevector-u8-ref t (fix:+ ts i)))
(fi (bytevector-u8-ref f (fix:+ fs i))))
(lambda (k)
(let ((result
(test-for-io-on-channel server-socket
- 'READ
+ 'read
block?)))
(case result
- ((READ)
+ ((read)
(open-channel
(lambda (p)
(with-thread-timer-stopped
(channel-descriptor server-socket)
peer-address
p))))))
- ((PROCESS-STATUS-CHANGE)
+ ((process-status-change)
(handle-subprocess-status-change)
(if (channel-closed? server-socket) #f (k)))
(else
(define socket-port-type)
(define (initialize-package!)
(set! socket-port-type
- (make-textual-port-type `((CLOSE-INPUT ,socket/close-input)
- (CLOSE-OUTPUT ,socket/close-output))
- (generic-i/o-port-type 'CHANNEL 'CHANNEL)))
+ (make-textual-port-type `((close-input ,socket/close-input)
+ (close-output ,socket/close-output))
+ (generic-i/o-port-type 'channel 'channel)))
unspecific)
(define (socket/close-input port)
;;;; Selectors
(define (take lis k)
- (guarantee index-fixnum? k 'TAKE)
+ (guarantee index-fixnum? k 'take)
(let recur ((lis lis) (k k))
(if (fix:> k 0)
(cons (car lis)
'())))
(define (drop lis k)
- (guarantee index-fixnum? k 'DROP)
+ (guarantee index-fixnum? k 'drop)
(%drop lis k))
(define (%drop lis k)
lis)))
(define (take! lis k)
- (guarantee index-fixnum? k 'TAKE!)
+ (guarantee index-fixnum? k 'take!)
(if (fix:> k 0)
(begin
(set-cdr! (drop lis (fix:- k 1)) '())
;;; the end.
(define (take-right lis k)
- (guarantee index-fixnum? k 'TAKE-RIGHT)
+ (guarantee index-fixnum? k 'take-right)
(let lp ((lag lis) (lead (%drop lis k)))
(if (pair? lead)
(lp (cdr lag) (cdr lead))
lag)))
(define (drop-right lis k)
- (guarantee index-fixnum? k 'DROP-RIGHT)
+ (guarantee index-fixnum? k 'drop-right)
(let recur ((lag lis) (lead (%drop lis k)))
(if (pair? lead)
(cons (car lag) (recur (cdr lag) (cdr lead)))
;;; us stop LAG one step early, in time to smash its cdr to ().
(define (drop-right! lis k)
- (guarantee index-fixnum? k 'DROP-RIGHT!)
+ (guarantee index-fixnum? k 'drop-right!)
(let ((lead (%drop lis k)))
(if (pair? lead)
;; Standard case
'())))
(define (split-at x k)
- (guarantee index-fixnum? k 'SPLIT-AT)
+ (guarantee index-fixnum? k 'split-at)
(let recur ((lis x) (k k))
(if (fix:> k 0)
(receive (prefix suffix) (recur (cdr lis) (fix:- k 1))
(values '() lis))))
(define (split-at! x k)
- (guarantee index-fixnum? k 'SPLIT-AT!)
+ (guarantee index-fixnum? k 'split-at!)
(if (fix:> k 0)
(let* ((prev (%drop x (fix:- k 1)))
(suffix (cdr prev)))
(define (append-reverse rev-head tail)
(let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head 'APPEND-REVERSE)
+ (if (null-list? rev-head 'append-reverse)
tail
(lp (cdr rev-head) (cons (car rev-head) tail)))))
(define (append-reverse! rev-head tail)
(let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head 'APPEND-REVERSE!)
+ (if (null-list? rev-head 'append-reverse!)
tail
(let ((next-rev (cdr rev-head)))
(set-cdr! rev-head tail)
(define (count pred list1 . lists)
(if (pair? lists)
(let lp ((list1 list1) (lists lists) (i 0))
- (if (null-list? list1 'COUNT)
+ (if (null-list? list1 'count)
i
(receive (as ds) (%cars+cdrs lists)
(if (null? as)
(define (unzip2 lis)
(let recur ((lis lis))
- (if (null-list? lis 'UNZIP2)
+ (if (null-list? lis 'unzip2)
(values lis lis)
(let ((elt (car lis)))
(receive (a b) (recur (cdr lis))
(define (unzip3 lis)
(let recur ((lis lis))
- (if (null-list? lis 'UNZIP3)
+ (if (null-list? lis 'unzip3)
(values lis lis lis)
(let ((elt (car lis)))
(receive (a b c) (recur (cdr lis))
(define (unzip4 lis)
(let recur ((lis lis))
- (if (null-list? lis 'UNZIP4)
+ (if (null-list? lis 'unzip4)
(values lis lis lis lis)
(let ((elt (car lis)))
(receive (a b c d) (recur (cdr lis))
(define (unzip5 lis)
(let recur ((lis lis))
- (if (null-list? lis 'UNZIP5)
+ (if (null-list? lis 'unzip5)
(values lis lis lis lis lis)
(let ((elt (car lis)))
(receive (a b c d e) (recur (cdr lis))
ans
(lp tails (apply f (append! lists (list ans)))))))
(let lp ((lis lis1) (ans zero))
- (if (null-list? lis 'PAIR-FOLD)
+ (if (null-list? lis 'pair-fold)
ans
;; Grab the cdr now, in case F SET-CDR!s LIS.
(let ((tail (cdr lis)))
zero
(apply f (append! lists (list (recur cdrs)))))))
(let recur ((lis lis1))
- (if (null-list? lis 'PAIR-FOLD-RIGHT)
+ (if (null-list? lis 'pair-fold-right)
zero
(f lis (recur (cdr lis)))))))
(apply proc lists)
(lp tails)))))
(let lp ((lis lis1))
- (if (not (null-list? lis 'PAIR-FOR-EACH))
+ (if (not (null-list? lis 'pair-for-each))
;; Grab the cdr now, in case PROC SET-CDR!s LIS.
(let ((tail (cdr lis)))
(proc lis)
(define (map! f lis1 . lists)
(if (pair? lists)
(let lp ((lis1 lis1) (lists lists))
- (if (not (null-list? lis1 'MAP!))
+ (if (not (null-list? lis1 'map!))
(receive (heads tails) (%cars+cdrs/no-test lists)
(set-car! lis1 (apply f (car lis1) heads))
(lp (cdr lis1) tails))))
(else (recur cdrs))) ; Tail call in this arm.
'())))
(let recur ((lis lis1))
- (if (null-list? lis 'FILTER-MAP)
+ (if (null-list? lis 'filter-map)
lis
(let ((tail (recur (cdr lis))))
(cond ((f (car lis)) => (lambda (x) (cons x tail)))
(cons x (recur cdrs)))
'())))
(let recur ((lis lis1))
- (if (null-list? lis 'MAP-IN-ORDER)
+ (if (null-list? lis 'map-in-order)
lis
;; Do head first, then tail.
(let ((x (f (car lis))))
(define (filter pred lis)
(let recur ((lis lis))
- (if (null-list? lis 'FILTER)
+ (if (null-list? lis 'filter)
lis
(let ((head (car lis))
(tail (cdr lis)))
(define (filter! pred lis)
(let lp ((ans lis))
- (cond ((null-list? ans 'FILTER!) ans) ; Scan looking for
+ (cond ((null-list? ans 'filter!) ans) ; Scan looking for
((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
;; ANS is the eventual answer.
(define (partition pred lis)
(let recur ((lis lis))
- (if (null-list? lis 'PARTITION)
+ (if (null-list? lis 'partition)
(values lis lis)
(let ((elt (car lis))
(tail (cdr lis)))
;;; lists.
(define (partition! pred lis)
- (if (null-list? lis 'PARTITION!)
+ (if (null-list? lis 'partition!)
(values lis lis)
;; This pair of loops zips down contiguous in & out runs of the
(define (delete-duplicates lis #!optional elt=)
(let ((elt= (if (default-object? elt=) equal? elt=)))
(let recur ((lis lis))
- (if (null-list? lis 'DELETE-DUPLICATES)
+ (if (null-list? lis 'delete-duplicates)
lis
(let* ((x (car lis))
(tail (cdr lis))
(define (delete-duplicates! lis #!optional elt=)
(let ((elt= (if (default-object? elt=) equal? elt=)))
(let recur ((lis lis))
- (if (null-list? lis 'DELETE-DUPLICATES!)
+ (if (null-list? lis 'delete-duplicates!)
lis
(let* ((x (car lis))
(tail (cdr lis))
(define (find-tail pred list)
(let lp ((list list))
- (and (not (null-list? list 'FIND-TAIL))
+ (and (not (null-list? list 'find-tail))
(if (pred (car list)) list
(lp (cdr list))))))
(define (take-while pred lis)
(let recur ((lis lis))
- (if (null-list? lis 'TAKE-WHILE)
+ (if (null-list? lis 'take-while)
'()
(let ((x (car lis)))
(if (pred x)
(define (drop-while pred lis)
(let lp ((lis lis))
- (if (null-list? lis 'DROP-WHILE)
+ (if (null-list? lis 'drop-while)
'()
(if (pred (car lis))
(lp (cdr lis))
lis))))
(define (take-while! pred lis)
- (if (or (null-list? lis 'TAKE-WHILE!)
+ (if (or (null-list? lis 'take-while!)
(not (pred (car lis))))
'()
(begin
\f
(define (span pred lis)
(let recur ((lis lis))
- (if (null-list? lis 'SPAN)
+ (if (null-list? lis 'span)
(values '() '())
(let ((x (car lis)))
(if (pred x)
(values '() lis))))))
(define (span! pred lis)
- (if (or (null-list? lis 'SPAN!)
+ (if (or (null-list? lis 'span!)
(not (pred (car lis))))
(values '() lis)
(let ((suffix (let lp ((prev lis) (rest (cdr lis)))
- (if (null-list? rest 'SPAN!)
+ (if (null-list? rest 'span!)
rest
(let ((x (car rest)))
(if (pred x) (lp rest (cdr rest))
(or (apply pred heads)
(lp next-heads next-tails))
(apply pred heads))))))
- (and (not (null-list? lis1 'ANY))
+ (and (not (null-list? lis1 'any))
(let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail 'ANY)
+ (if (null-list? tail 'any)
(pred head)
(or (pred head)
(lp (car tail) (cdr tail))))))))
(and (apply pred heads)
(lp next-heads next-tails))
(apply pred heads))))))
- (or (null-list? lis1 'EVERY)
+ (or (null-list? lis1 'every)
(let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail 'EVERY)
+ (if (null-list? tail 'every)
(pred head)
(and (pred head)
(lp (car tail) (cdr tail))))))))
(if (apply pred heads) n
(lp tails (fix:+ n 1))))))
(let lp ((lis lis1) (n 0))
- (and (not (null-list? lis 'LIST-INDEX))
+ (and (not (null-list? lis 'list-index))
(if (pred (car lis))
n
(lp (cdr lis) (fix:+ n 1)))))))
(define (lset-union = . lists)
(reduce (lambda (lis ans) ; Compute ANS + LIS.
(cond ((null? lis) ans) ; Don't copy any lists
- ((null? ans) lis) ; if we don't have to.
+ ((null? ans) lis) ; if we don't have to.
((eq? lis ans) ans)
(else
(fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
(define (lset-intersection = lis1 . lists)
(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
(cond ((any (lambda (list)
- (null-list? list 'LSET-INTERSECTION))
+ (null-list? list 'lset-intersection))
lists)
'()) ; Short cut
((null? lists) lis1) ; Short cut
(define (lset-intersection! = lis1 . lists)
(let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
(cond ((any (lambda (list)
- (null-list? list 'LSET-INTERSECTION!))
+ (null-list? list 'lset-intersection!))
lists)
'()) ; Short cut
((null? lists) lis1) ; Short cut
(define (lset-diff+intersection = lis1 . lists)
(cond ((every (lambda (list)
- (null-list? list 'LSET-DIFF+INTERSECTION))
+ (null-list? list 'lset-diff+intersection))
lists)
(values lis1 '())) ; Short cut
((memq lis1 lists) (values '() lis1)) ; Short cut
lis1))))
(define (lset-diff+intersection! = lis1 . lists)
(cond ((every (lambda (list)
- (null-list? list 'LSET-DIFF+INTERSECTION!))
+ (null-list? list 'lset-diff+intersection!))
lists)
(values lis1 '())) ; Short cut
((memq lis1 lists) (values '() lis1)) ; Short cut
;;;; Miscellaneous Kludgerosity
(define (compiled-entry? object)
- (object-type? (ucode-type COMPILED-ENTRY) object))
+ (object-type? (ucode-type compiled-entry) object))
-(define event-return-address 'UNINITIALIZED)
+(define event-return-address 'uninitialized)
(define (initialize-package!)
(set! stack-sampling-return-address (make-unsettable-parameter #f))
(and (eq? stack-frame-type/compiled-return-address
(stack-frame/type stack-frame))
(stack-frame/return-address stack-frame))))))))
- (do () ((not (eq? event-return-address 'UNINITIALIZED)))
+ (do () ((not (eq? event-return-address 'uninitialized)))
(suspend-current-thread))
(if (not blocked?)
(unblock-thread-events))))
(define (deregister-event)
(deregister-timer-event timer-registration)
(set! timer-registration #f))
- (values (with-simple-restart 'ABORT "Abort stack sampling."
+ (values (with-simple-restart 'abort "Abort stack sampling."
(lambda ()
(dynamic-wind
register-event
profile)))
(define (carefully-record-sample profile continuation)
- (with-simple-restart 'CONTINUE "Ignore the sample."
+ (with-simple-restart 'continue "Ignore the sample."
(lambda ()
(let ((ignore (first-bound-restart))) ;silly
(define (go) (record-sample profile continuation))
(define-guarantee stream-pair "stream pair")
(define (stream-car stream)
- (guarantee stream-pair? stream 'STREAM-CAR)
+ (guarantee stream-pair? stream 'stream-car)
(car stream))
(define (stream-cdr stream)
- (guarantee stream-pair? stream 'STREAM-CDR)
+ (guarantee stream-pair? stream 'stream-cdr)
(force (cdr stream)))
(define the-empty-stream '())
(loop (force (cdr stream)) (+ n 1))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-LENGTH 0))
+ (error:illegal-stream-element stream 'stream-length 0))
n))))
(define (stream-ref stream index)
(let ((tail (stream-tail stream index)))
(if (not (stream-pair? tail))
- (error:bad-range-argument index 'STREAM-REF))
+ (error:bad-range-argument index 'stream-ref))
(car tail)))
(define (stream-head stream index)
- (guarantee exact-nonnegative-integer? index 'STREAM-HEAD)
+ (guarantee exact-nonnegative-integer? index 'stream-head)
(let loop ((stream stream) (index index))
(if (> index 0)
(begin
(if (not (stream-pair? stream))
- (error:bad-range-argument index 'STREAM-HEAD))
+ (error:bad-range-argument index 'stream-head))
(cons (car stream)
(loop (force (cdr stream)) (- index 1))))
'())))
(define (stream-tail stream index)
- (guarantee exact-nonnegative-integer? index 'STREAM-TAIL)
+ (guarantee exact-nonnegative-integer? index 'stream-tail)
(let loop ((stream stream) (index index))
(if (> index 0)
(begin
(if (not (stream-pair? stream))
- (error:bad-range-argument index 'STREAM-TAIL))
+ (error:bad-range-argument index 'stream-tail))
(loop (force (cdr stream)) (- index 1)))
stream)))
(define (stream-last-pair stream)
(if (not (stream-pair? stream))
(if (null? stream)
- (error:bad-range-argument stream 'STREAM-LAST-PAIR)
- (error:illegal-stream-element stream 'STREAM-LAST-PAIR 0)))
+ (error:bad-range-argument stream 'stream-last-pair)
+ (error:illegal-stream-element stream 'stream-last-pair 0)))
(let loop ((stream stream))
(let ((next (force (cdr stream))))
(if (stream-pair? next)
(loop next)
(begin
(if (not (null? next))
- (error:illegal-stream-element stream 'STREAM-LAST-PAIR 0))
+ (error:illegal-stream-element stream 'stream-last-pair 0))
stream)))))
\f
(define (stream-map procedure stream . streams)
(cond ((pair? streams)
(let loop ((streams (cons stream streams)))
- (receive (cars cdrs) (split-streams streams 'STREAM-MAP)
+ (receive (cars cdrs) (split-streams streams 'stream-map)
(if (pair? cars)
(cons-stream (apply procedure cars)
(loop (map force cdrs)))
(loop (force (cdr stream))))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-MAP 1))
+ (error:illegal-stream-element stream 'stream-map 1))
'()))))
((and (procedure? stream)
(or (null? procedure) (stream-pair? procedure)))
(define (stream-for-each procedure stream . streams)
(if (pair? streams)
(let loop ((streams (cons stream streams)))
- (receive (cars cdrs) (split-streams streams 'STREAM-FOR-EACH)
+ (receive (cars cdrs) (split-streams streams 'stream-for-each)
(if (pair? cars)
(begin
(apply procedure cars)
(procedure (car stream))
(loop (force (cdr stream))))
((not (null? stream))
- (error:illegal-stream-element stream 'STREAM-FOR-EACH 1))))))
+ (error:illegal-stream-element stream 'stream-for-each 1))))))
(define (split-streams streams operator)
- (let ((cars (list 'CARS))
- (cdrs (list 'CDRS)))
+ (let ((cars (list 'cars))
+ (cdrs (list 'cdrs)))
(let loop ((streams streams) (cars-tail cars) (cdrs-tail cdrs) (n 0))
(if (pair? streams)
(let ((stream (car streams)))
(cons-stream (car s) (loop (force (cdr s))))
(begin
(if (not (null? s))
- (error:illegal-stream-element s1 'STREAM-APPEND 0))
+ (error:illegal-stream-element s1 'stream-append 0))
(force s2)))))))
(if (pair? streams)
(let loop ((streams (cons stream streams)))
- (receive (cars cdrs) (split-streams streams 'STREAM-APPEND-MAP)
+ (receive (cars cdrs) (split-streams streams 'stream-append-map)
(if (pair? cars)
(sappend (apply procedure cars)
(delay (loop (map force cdrs))))
(delay (loop (force (cdr stream)))))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-APPEND-MAP 1))
+ (error:illegal-stream-element stream 'stream-append-map 1))
'()))))))
(define (stream-append . streams)
(inner-loop (force (cdr stream))))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-APPEND n))
+ (error:illegal-stream-element stream 'stream-append n))
(outer-loop (cdr streams) (fix:+ n 1)))))
(car streams)))
'()))
(stream-accumulate procedure initial (force (cdr stream))))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-ACCUMULATE 2))
+ (error:illegal-stream-element stream 'stream-accumulate 2))
initial)))
(define (stream-filter predicate stream)
(stream-filter predicate (force (cdr stream))))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-FILTER 1))
+ (error:illegal-stream-element stream 'stream-filter 1))
'())))
(define (stream-truncate stream predicate)
(stream-truncate (tail stream) predicate)))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-TRUNCATE 1))
+ (error:illegal-stream-element stream 'stream-truncate 1))
'())))
(define (stream-write stream #!optional port)
(let ((port
(if (default-object? port)
(current-output-port)
- (guarantee textual-output-port? port 'STREAM-WRITE))))
+ (guarantee textual-output-port? port 'stream-write))))
(if (stream-pair? stream)
(begin
(write-char #\{ port)
(write-char #\} port))
(begin
(if (not (null? stream))
- (error:illegal-stream-element stream 'STREAM-WRITE 0))
+ (error:illegal-stream-element stream 'stream-write 0))
(write-string "{}" port)))))
(define (list->stream list)
(cons-stream (car list) (list->stream (cdr list)))
(begin
(if (not (null? list))
- (error:not-a list? list 'LIST->STREAM))
+ (error:not-a list? list 'list->stream))
'())))
(define (stream->list stream)
(elements '()))
(cond ((stream-pair? s) (loop (tail s) (cons (head s) elements)))
((null? s) (reverse elements))
- (else (error:illegal-stream-element s 'STREAM->LIST 0)))))
+ (else (error:illegal-stream-element s 'stream->list 0)))))
\f
(define prime-numbers-stream)
(define (initialize-conditions!)
(set! condition-type:illegal-stream-element
- (make-condition-type 'ILLEGAL-STREAM-ELEMENT
+ (make-condition-type 'illegal-stream-element
condition-type:wrong-type-argument
'()
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string ", passed as the " port)
(write-string (ordinal-number-string
- (+ (access-condition condition 'OPERAND) 1))
+ (+ (access-condition condition 'operand) 1))
port)
(write-string " argument to " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string ", is not a stream." port))))
(set! error:illegal-stream-element
(let ((signaller
(condition-signaller condition-type:illegal-stream-element
- '(TYPE DATUM OPERATOR OPERAND)
+ '(type datum operator operand)
standard-error-handler)))
(named-lambda (error:illegal-stream-element stream operator operand)
(signaller "stream" stream operator operand))))
unspecific))))
(define (serve socket)
- (with-simple-restart 'DISCONNECT "Close connection."
+ (with-simple-restart 'disconnect "Close connection."
(lambda ()
(with-keyboard-interrupt-handler
(lambda ()
(new-handler
(lambda (char)
char
- (with-simple-restart 'CONTINUE "Continue from interrupt."
+ (with-simple-restart 'continue "Continue from interrupt."
(lambda ()
(error "Keyboard Interrupt.")))))
(old-handler))
unspecific))))
(define (disconnect)
- (invoke-restart (find-restart 'DISCONNECT)))
+ (invoke-restart (find-restart 'disconnect)))
\f
(define (main-loop socket)
(do () (#f)
- (with-simple-restart 'ABORT "Return to SLIME top-level."
+ (with-simple-restart 'abort "Return to SLIME top-level."
(lambda ()
- (parameterize* (list (cons *top-level-restart* (find-restart 'ABORT)))
+ (parameterize* (list (cons *top-level-restart* (find-restart 'abort)))
(lambda ()
(process-one-message socket 0)))))))
#t)
:repl-result)
socket)
- 'NIL)
+ 'nil)
(define (interactive-eval sexp socket nl?)
(let ((value (repl-eval sexp socket)))
(define (repl-eval sexp socket)
(with-output-to-repl socket
(lambda ()
- (with-repl-eval-boundary 'SWANK
+ (with-repl-eval-boundary 'swank
(lambda ()
(eval sexp (buffer-env)))))))
(set! *buffer-pstring* (make-unsettable-parameter unspecific))
(set! repl-port-type
(make-textual-port-type
- `((WRITE-CHAR
+ `((write-char
,(lambda (port char)
(write-message `(:write-string ,(string char))
(textual-port-state port))
1))
- (WRITE-SUBSTRING
+ (write-substring
,(lambda (port string start end)
(if (< start end)
(write-message `(:write-string ,(substring string start end))
run-time gc-time
(set! time real-time)
unspecific))
- (list 'NIL (string (internal-time/ticks->seconds time)))))
+ (list 'nil (string (internal-time/ticks->seconds time)))))
(define (swank:compile-file-for-emacs socket file load?)
(call-compiler
(carefully-pa
(eval (read-from-string name)
(pstring->env pstring)))))))))))
- (if (condition? v) 'NIL v)))
+ (if (condition? v) 'nil v)))
(define (carefully-pa o)
(cond ((arity-dispatched-procedure? o)
(define (swank:buffer-first-change socket filename)
socket filename
- 'NIL)
+ 'nil)
;; M-. is beyond my capabilities.
(define (swank:find-definitions-for-emacs socket name)
socket name
- 'NIL)
+ 'nil)
#|
;;; List of names obtained by grepping through "slime.el" and
socket)
(sldb-loop level socket))
(lambda ()
- (write-message `(:debug-return 0 ,(- level 1) 'NIL) socket))))))
+ (write-message `(:debug-return 0 ,(- level 1) 'nil) socket))))))
(define (sldb-loop level socket)
(write-message `(:debug-activate 0 ,level) socket)
- (with-simple-restart 'ABORT (string "Return to SLDB level " level ".")
+ (with-simple-restart 'abort (string "Return to SLDB level " level ".")
(lambda ()
(process-one-message socket level)))
(sldb-loop level socket))
(rs (sldb-state.restarts state)))
(list (list (condition/report-string c)
(string " [" (condition-type/name (condition/type c)) "]")
- 'NIL)
+ 'nil)
(sldb-restarts rs)
(sldb-backtrace c start end)
;;'((0 "dummy frame"))
(map (lambda (symbol)
`((:designator ,(string symbol " " pstring))
,@(case (environment-reference-type env symbol)
- ((UNBOUND) '())
- ((UNASSIGNED) `((:variable nil)))
- ((MACRO) `((:macro nil)))
+ ((unbound) '())
+ ((unassigned) `((:variable nil)))
+ ((macro) `((:macro nil)))
(else
(let ((v (environment-lookup env symbol)))
`((,(cond ((procedure? v) ':function)
(cond ((istate-previous istate)
(set! istate (istate-previous istate))
(istate->elisp istate))
- (else 'NIL)))
+ (else 'nil)))
(define (swank:inspector-next socket)
socket
(cond ((istate-next istate)
(set! istate (istate-next istate))
(istate->elisp istate))
- (else 'NIL)))
+ (else 'nil)))
(define (swank:inspector-range socket from to)
socket
from to))
(define (iline label value)
- `(LINE ,label ,value))
+ `(line ,label ,value))
(define (inspect o)
(cond ((environment? o) (inspect-environment o))
\f
;;;; Auxilary functions
-(define (elisp-false? o) (or (null? o) (eq? o 'NIL)))
+(define (elisp-false? o) (or (null? o) (eq? o 'nil)))
(define (elisp-true? o) (not (elisp-false? o)))
(define (->line o)
(declare (usual-integrations))
-(load-option 'SUBPROCESS)
+(load-option 'subprocess)
\f
(define-structure (subprocess-context
(keyword-constructor make-subprocess-context)
(let loop ()
(receive (status reason) (synchronous-subprocess-wait process context)
(case status
- ((EXITED) reason)
- ((SIGNALLED) (error:subprocess-signalled process reason))
+ ((exited) reason)
+ ((signalled) (error:subprocess-signalled process reason))
;++ Give a restart to continue the process and loop?
- ((STOPPED) (error:subprocess-stopped process reason))
+ ((stopped) (error:subprocess-stopped process reason))
(else
(error "Invalid synchronous subprocess status:" status))))))
(lambda ()
(if (and process
;++ Need a predicate SUBPROCESS-LIVE? or something.
- (not (memq (subprocess-status process) '(EXITED SIGNALLED))))
+ (not (memq (subprocess-status process) '(exited signalled))))
(ignore-errors (lambda () (subprocess-kill process))))))))
(define (start-subprocess program arguments directory context)
environment))))
\f
(define condition-type:subprocess-abnormal-termination
- (make-condition-type 'SUBPROCESS-ABNORMAL-TERMINATION condition-type:error
- '(SUBPROCESS REASON)
+ (make-condition-type 'subprocess-abnormal-termination condition-type:error
+ '(subprocess reason)
#f))
(define (abnormal-termination-type name message)
'()
(lambda (condition port)
(write-string "Subprocess " port)
- (write (access-condition condition 'SUBPROCESS) port)
+ (write (access-condition condition 'subprocess) port)
(write-string " " port)
(write-string message port)
(write-string " " port)
- (write (access-condition condition 'REASON) port)
+ (write (access-condition condition 'reason) port)
(write-string "." port))))
(define condition-type:subprocess-stopped
- (abnormal-termination-type 'SUBPROCESS-STOPPED "stopped with signal"))
+ (abnormal-termination-type 'subprocess-stopped "stopped with signal"))
(define error:subprocess-stopped
(condition-signaller condition-type:subprocess-stopped
- '(SUBPROCESS REASON)
+ '(subprocess reason)
standard-error-handler))
(define condition-type:subprocess-signalled
- (abnormal-termination-type 'SUBPROCESS-SIGNALLED "terminated with signal"))
+ (abnormal-termination-type 'subprocess-signalled "terminated with signal"))
(define error:subprocess-signalled
(condition-signaller condition-type:subprocess-signalled
- '(SUBPROCESS REASON)
+ '(subprocess reason)
standard-error-handler))
(define (synchronous-subprocess-wait process context)
(pattern object))
((symbol? pattern)
(case pattern
- ((SYMBOL) (symbol? object))
- ((IDENTIFIER) (identifier? object))
- ((DATUM EXPRESSION FORM) #t)
- ((R4RS-BVL) (r4rs-lambda-list? object))
- ((MIT-BVL) (mit-lambda-list? object))
- ((STRING) (string? object))
- ((CHAR) (char? object))
- ((URI) (->uri object #f))
- ((INDEX) (exact-nonnegative-integer? object))
+ ((symbol) (symbol? object))
+ ((identifier) (identifier? object))
+ ((datum expression form) #t)
+ ((r4rs-bvl) (r4rs-lambda-list? object))
+ ((mit-bvl) (mit-lambda-list? object))
+ ((string) (string? object))
+ ((char) (char? object))
+ ((uri) (->uri object #f))
+ ((index) (exact-nonnegative-integer? object))
(else (match-error))))
((pair? pattern)
(case (car pattern)
(syntax-match? pattern object))
(cdr pattern))
(match-error)))
- ((QUOTE)
+ ((quote)
(if (and (pair? (cdr pattern))
(null? (cddr pattern)))
(eqv? (cadr pattern) object)
(define known-declarations '())
(for-each (lambda (keyword)
- (define-declaration keyword '(* IDENTIFIER)
+ (define-declaration keyword '(* identifier)
(lambda (procedure declaration selector)
(cons (car declaration)
(map+ procedure
(define (add-subsystem-identification! name version)
(if (not (and (string? name) (not (string-null? name))))
(error:wrong-type-argument name "non-null string"
- 'ADD-SUBSYSTEM-IDENTIFICATION!))
+ 'add-subsystem-identification!))
(let ((version
(let loop ((version version))
(append-map (lambda (version)
projects / mit-scheme.git / commitdiff