(let ((definition-analysis (map analyze/top-level/definition definitions)))
(if (pair? others)
(cons (vector false
- 'EXPRESSION
+ 'expression
(analyze-and-compress (make-scode-sequence others)))
definition-analysis)
definition-analysis))))
(let ((name (scode-definition-name definition))
(expression (scode-definition-value definition)))
(cond ((unassigned-reference-trap? expression)
- (vector name 'UNASSIGNED '#()))
+ (vector name 'unassigned '#()))
((scode-constant? expression)
- (vector name 'CONSTANT '#()))
+ (vector name 'constant '#()))
(else
(vector name
- (cond ((scode-lambda? expression) 'LAMBDA)
- ((scode-delay? expression) 'DELAY)
- (else 'EXPRESSION))
+ (cond ((scode-lambda? expression) 'lambda)
+ ((scode-delay? expression) 'delay)
+ (else 'expression))
(analyze-and-compress expression))))))
(define (analyze-and-compress expression)
(define analyze/dispatch
(make-scode-walker
analyze/uninteresting
- `((ACCESS ,analyze/access)
- (ASSIGNMENT ,analyze/assignment)
- (COMBINATION ,analyze/combination)
- (COMMENT ,analyze/comment)
- (CONDITIONAL ,analyze/conditional)
- (DEFINITION ,analyze/error)
- (DELAY ,analyze/delay)
- (DISJUNCTION ,analyze/disjunction)
- (ERROR-COMBINATION ,analyze/error-combination)
- (LAMBDA ,analyze/lambda)
- (SEQUENCE ,analyze/sequence)
- (VARIABLE ,analyze/variable))))
+ `((access ,analyze/access)
+ (assignment ,analyze/assignment)
+ (combination ,analyze/combination)
+ (comment ,analyze/comment)
+ (conditional ,analyze/conditional)
+ (definition ,analyze/error)
+ (delay ,analyze/delay)
+ (disjunction ,analyze/disjunction)
+ (error-combination ,analyze/error-combination)
+ (lambda ,analyze/lambda)
+ (sequence ,analyze/sequence)
+ (variable ,analyze/variable))))
(define (eq-set-adjoin x y)
(if (memq x y)
(integrate-external "object"))
\f
(define (construct-external-descriptions pmodel)
- (vector 'PACKAGE-DESCRIPTIONS ;tag
+ (vector 'package-descriptions ;tag
2 ;version
(list->vector
(map cdr
(constructor make-package (name parent))
(conc-name package/)
(print-procedure
- (simple-unparser-method 'PACKAGE
+ (simple-unparser-method 'package
(lambda (package)
(list (package/name package))))))
(name #f read-only #t)
(constructor %make-binding (package name value-cell new?))
(conc-name binding/)
(print-procedure
- (simple-unparser-method 'BINDING
+ (simple-unparser-method 'binding
(lambda (binding)
(list (binding/name binding)
(package/name (binding/package binding)))))))
(constructor %make-reference (package name))
(conc-name reference/)
(print-procedure
- (simple-unparser-method 'REFERENCE
+ (simple-unparser-method 'reference
(lambda (reference)
(list (reference/name reference)
(package/name (reference/package reference)))))))
(let ((description (car descriptions))
(descriptions (cdr descriptions)))
(case (car description)
- ((DEFINE-PACKAGE)
+ ((define-package)
(loop descriptions
(cons (cdr description) packages)
extensions
(cons (cdr description) loads)
loads)
globals))
- ((EXTEND-PACKAGE)
+ ((extend-package)
(loop descriptions
packages
(cons (cdr description) extensions)
(cons (cdr description) loads)
loads)
globals))
- ((GLOBAL-DEFINITIONS)
+ ((global-definitions)
(loop descriptions
packages
extensions
loads
(append! (reverse (cdr description)) globals)))
- ((NESTED-DESCRIPTIONS)
+ ((nested-descriptions)
(receive (packages extensions loads globals)
(loop (cdr description)
packages
(list? (cdr expression))))
(lose))
(case (car expression)
- ((DEFINE-PACKAGE)
- (cons 'DEFINE-PACKAGE
+ ((define-package)
+ (cons 'define-package
(parse-package-definition (parse-name (cadr expression))
(cddr expression))))
- ((EXTEND-PACKAGE)
- (cons 'EXTEND-PACKAGE
+ ((extend-package)
+ (cons 'extend-package
(parse-package-extension (parse-name (cadr expression))
(cddr expression))))
- ((GLOBAL-DEFINITIONS)
+ ((global-definitions)
(let ((filenames (cdr expression)))
(if (not (every (lambda (f) (or (string? f) (symbol? f))) filenames))
(lose))
- (cons 'GLOBAL-DEFINITIONS filenames)))
- ((OS-TYPE-CASE)
+ (cons 'global-definitions filenames)))
+ ((os-type-case)
(if (not (and (list? (cdr expression))
(every (lambda (clause)
- (and (or (eq? 'ELSE (car clause))
+ (and (or (eq? 'else (car clause))
(and (list? (car clause))
(every symbol? (car clause))))
(list? (cdr clause))))
(cdr expression))))
(lose))
- (cons 'NESTED-DESCRIPTIONS
+ (cons 'nested-descriptions
(let loop ((clauses (cdr expression)))
(cond ((null? clauses)
'())
- ((or (eq? 'ELSE (caar clauses))
+ ((or (eq? 'else (caar clauses))
(memq os-type (caar clauses)))
(parse-package-expressions (cdar clauses)
pathname
os-type))
(else
(loop (cdr clauses)))))))
- ((INCLUDE)
- (cons 'NESTED-DESCRIPTIONS
+ ((include)
+ (cons 'nested-descriptions
(let ((filenames (cdr expression)))
(if (not (every string? filenames))
(lose))
(define (parse-package-definition name options)
(check-package-options options)
(receive (parent options)
- (let ((option (assq 'PARENT options)))
+ (let ((option (assq 'parent options)))
(if option
(let ((options (delq option options)))
(if (not (and (pair? (cdr option))
(null? (cddr option))))
(error "Ill-formed PARENT option:" option))
- (if (assq 'PARENT options)
+ (if (assq 'parent options)
(error "Multiple PARENT options."))
(values (and (cadr option)
(parse-name (cadr option)))
options))
- (values 'NONE options)))
+ (values 'none options)))
(let ((package (make-package-description name parent)))
(process-package-options package options)
package)))
(define (parse-package-extension name options)
(check-package-options options)
- (let ((option (assq 'PARENT options)))
+ (let ((option (assq 'parent options)))
(if option
(error "PARENT option illegal in package extension:" option)))
- (let ((package (make-package-description name 'NONE)))
+ (let ((package (make-package-description name 'none)))
(process-package-options package options)
package))
(define (process-package-options package options)
(for-each (lambda (option)
(case (car option)
- ((FILES)
+ ((files)
(set-package-description/file-cases!
package
(append! (package-description/file-cases package)
(list (parse-filenames (cdr option))))))
- ((FILE-CASE)
+ ((file-case)
(set-package-description/file-cases!
package
(append! (package-description/file-cases package)
(list (parse-file-case (cdr option))))))
- ((EXPORT)
+ ((export)
(let ((export
(cond ((and (pair? (cdr option))
- (eq? 'DEPRECATED (cadr option)))
+ (eq? 'deprecated (cadr option)))
(parse-import/export (cddr option) #t))
;; 9.2 compatibility
((and (pair? (cdr option))
package
(append! (package-description/exports package)
(list export)))))
- ((EXPORT-DEPRECATED)
+ ((export-deprecated)
(set-package-description/exports!
package
(append! (package-description/exports package)
(list (parse-import/export (cdr option) #t)))))
- ((IMPORT)
+ ((import)
(set-package-description/imports!
package
(append! (package-description/imports package)
(list (parse-import/export (cdr option) #f)))))
- ((INITIALIZATION)
+ ((initialization)
(let ((initialization (parse-initialization (cdr option))))
(if initialization
(set-package-description/initializations!
package
(append! (package-description/initializations package)
(list initialization))))))
- ((FINALIZATION)
+ ((finalization)
(let ((finalization (parse-initialization (cdr option))))
(if finalization
(set-package-description/finalizations!
(define (parse-filenames filenames)
(if (not (check-list filenames string?))
(error "illegal filenames" filenames))
- (list #F (cons 'ELSE (map parse-filename filenames))))
+ (list #f (cons 'else (map parse-filename filenames))))
(define (parse-file-case file-case)
(if (not (and (pair? file-case)
(check-list (cdr file-case)
(lambda (clause)
(and (pair? clause)
- (or (eq? 'ELSE (car clause))
+ (or (eq? 'else (car clause))
(check-list (car clause) symbol?))
(check-list (cdr clause) string?))))))
(error "Illegal file-case" file-case))
(define (descriptions->pmodel descriptions extensions loads globals pathname)
(let ((packages
(map (lambda (description)
- (make-package (package-description/name description) 'UNKNOWN))
+ (make-package (package-description/name description) 'unknown))
descriptions))
(extra-packages '()))
(let ((root-package
(begin
(if (not intern?)
(warn "Unknown package name:" name))
- (let ((package (make-package name 'UNKNOWN)))
+ (let ((package (make-package name 'unknown)))
(set! extra-packages
(cons package extra-packages))
package)))))))
(let ((parent
(let ((parent-name (package-description/parent description)))
(and parent-name
- (not (eq? parent-name 'NONE))
+ (not (eq? parent-name 'none))
(get-package parent-name #t)))))
(set-package/parent! package parent)
(if parent
(let loop
((package package)
(ancestors (vector-ref desc 1)))
- (if (eq? 'UNKNOWN (package/parent package))
+ (if (eq? 'unknown (package/parent package))
(if (pair? ancestors)
(let ((parent (get-package (car ancestors) #t)))
(set-package/parent! package parent)
(for-each-vector-element (vector-ref desc 4)
(lambda (entry)
(let ((external-package (get-package (vector-ref entry 1) #t))
- (external-name
+ (external-name
(if (fix:= (vector-length entry) 2)
(vector-ref entry 0)
(vector-ref entry 2))))
(resolve-references! pmodel)
(kernel pathname pmodel changes? os-type)))))))
(cond ((default-object? os-type) (do-type microcode-id/operating-system))
- ((eq? os-type 'ALL) (for-each do-type os-types))
+ ((eq? os-type 'all) (for-each do-type os-types))
((memq os-type os-types) (do-type os-type))
(else (error:bad-range-argument os-type #f))))))
#f
os-type))))
(cond ((or (default-object? os-type)
- (eq? os-type 'ALL))
+ (eq? os-type 'all))
(for-each do-type os-types))
((eq? os-type #f)
(do-type microcode-id/operating-system))
(read-package-model filename os-type))))))
(define os-types
- '(NT UNIX))
+ '(nt unix))
\f
(define cref/generate-cref
(generate/common
(lambda (original-body state)
original-body
(if (not (pair? state))
- (error:bad-range-argument *lambda 'LAMBDA-ADVICE))
+ (error:bad-range-argument *lambda 'lambda-advice))
(values (car state) (cdr state)))))
(define (make-advice-hook)
(lambda (continuation)
(parameterize* (list (cons advice-continuation continuation))
(lambda ()
- (with-restart 'USE-VALUE
+ (with-restart 'use-value
"Return a value from the advised procedure."
continuation
(lambda ()
(prompt-for-evaluated-expression "Procedure value"))
(lambda ()
(for-each (lambda (advice)
- (with-simple-restart 'CONTINUE
+ (with-simple-restart 'continue
"Continue with advised procedure."
(lambda ()
(advice procedure arguments environment))))
(car state))
(let ((value (scode-eval original-body environment)))
(for-each (lambda (advice)
- (with-simple-restart 'CONTINUE
+ (with-simple-restart 'continue
"Return from advised procedure."
(lambda ()
(advice procedure
(clause clause)
(clauses clauses)
(free '()))
- `(COND ((PAIR? ,lv)
+ `(cond ((pair? ,lv)
,(if (pair? (cdr clauses))
(let ((av (car clause))
- (lv* (make-synthetic-identifier 'L)))
- `(LET ((,av (CAR ,lv))
- (,lv* (CDR ,lv)))
+ (lv* (make-synthetic-identifier 'l)))
+ `(let ((,av (car ,lv))
+ (,lv* (cdr ,lv)))
,(walk lv*
(car clauses)
(cdr clauses)
(cons av free))))
(make-syntactic-closure environment free
(cadr (car clauses)))))
- ((NULL? ,lv)
+ ((null? ,lv)
,(make-syntactic-closure environment free
(cadr clause)))
- (ELSE (FAIL))))
+ (else (fail))))
(make-syntactic-closure environment '() (cadr clause))))))))
(apply-dispatch&bind a0
(v0 (f))
(set! apply
(make-entity
apply-entity-procedure
- (vector (fixed-objects-item 'ARITY-DISPATCHER-TAG)
+ (vector (fixed-objects-item 'arity-dispatcher-tag)
(lambda ()
- (error:wrong-number-of-arguments apply '(1 . #F) '()))
+ (error:wrong-number-of-arguments apply '(1 . #f) '()))
(lambda (f) (f))
apply-2)))
unspecific)
\ No newline at end of file
(sc-macro-transformer
(lambda (form environment)
(let ((name (list-ref form 1)))
- `(SET! ,(close-syntax name environment)
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF Z1 . ZS)
- SELF ; ignored
+ `(set! ,(close-syntax name environment)
+ (make-entity
+ (named-lambda (,name self z1 . zs)
+ self ; ignored
(,(close-syntax (list-ref form 3) environment)
- Z1
- (REDUCE ,(close-syntax (list-ref form 4) environment)
+ z1
+ (reduce ,(close-syntax (list-ref form 4) environment)
,(close-syntax (list-ref form 5) environment)
- ZS)))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- #F
+ zs)))
+ (vector
+ (fixed-objects-item 'arity-dispatcher-tag)
+ #f
,(close-syntax (list-ref form 2) environment)
- (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2)
- ((UCODE-PRIMITIVE ,(list-ref form 6)) Z1 Z2))))))))))
+ (named-lambda (,(symbol 'binary- name) z1 z2)
+ ((ucode-primitive ,(list-ref form 6)) z1 z2))))))))))
(non-commutative - complex:negate complex:- complex:+ 0 &-)
(non-commutative / complex:invert complex:/ complex:* 1 &/))
\f
(lambda (form environment)
(let ((name (list-ref form 1))
(type (list-ref form 4)))
- `(SET! ,(close-syntax name environment)
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF . ZS)
- SELF ; ignored
- (REDUCE-COMPARATOR
+ `(set! ,(close-syntax name environment)
+ (make-entity
+ (named-lambda (,name self . zs)
+ self ; ignored
+ (reduce-comparator
,(close-syntax (list-ref form 2) environment)
- ZS ',name))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- (NAMED-LAMBDA (,(symbol 'NULLARY- name)) #T)
- (NAMED-LAMBDA (,(symbol 'UNARY- name) Z)
- (IF (NOT (,(intern (string-append "complex:" type "?"))
- Z))
- (ERROR:WRONG-TYPE-ARGUMENT
- Z ,(string-append type " number") ',name))
- #T)
- (NAMED-LAMBDA (,(symbol 'BINARY- name) Z1 Z2)
+ zs ',name))
+ (vector
+ (fixed-objects-item 'arity-dispatcher-tag)
+ (named-lambda (,(symbol 'nullary- name)) #t)
+ (named-lambda (,(symbol 'unary- name) z)
+ (if (not (,(intern (string-append "complex:" type "?"))
+ z))
+ (error:wrong-type-argument
+ z ,(string-append type " number") ',name))
+ #t)
+ (named-lambda (,(symbol 'binary- name) z1 z2)
,(let ((p
- `((UCODE-PRIMITIVE ,(list-ref form 3)) Z1 Z2)))
+ `((ucode-primitive ,(list-ref form 3)) z1 z2)))
(if (list-ref form 5)
- `(NOT ,p)
+ `(not ,p)
p)))))))))))
- (relational = complex:= &= "complex" #F)
- (relational < complex:< &< "real" #F)
- (relational > complex:> &> "real" #F)
- (relational <= (lambda (x y) (not (complex:< y x))) &> "real" #T)
- (relational >= (lambda (x y) (not (complex:< x y))) &< "real" #T))
+ (relational = complex:= &= "complex" #f)
+ (relational < complex:< &< "real" #f)
+ (relational > complex:> &> "real" #f)
+ (relational <= (lambda (x y) (not (complex:< y x))) &> "real" #t)
+ (relational >= (lambda (x y) (not (complex:< x y))) &< "real" #t))
(let-syntax
((max/min
(lambda (form environment)
(let ((name (list-ref form 1))
(generic-binary (close-syntax (list-ref form 2) environment)))
- `(SET! ,(close-syntax name environment)
- (MAKE-ENTITY
- (NAMED-LAMBDA (,name SELF X . XS)
- SELF ; ignored
- (REDUCE-MAX/MIN ,generic-binary X XS ',name))
- (VECTOR
- (FIXED-OBJECTS-ITEM 'arity-dispatcher-tag)
- #F
- (NAMED-LAMBDA (,(symbol 'UNARY- name) X)
- (IF (NOT (COMPLEX:REAL? X))
- (ERROR:WRONG-TYPE-ARGUMENT X "real number" ',name))
- X)
+ `(set! ,(close-syntax name environment)
+ (make-entity
+ (named-lambda (,name self x . xs)
+ self ; ignored
+ (reduce-max/min ,generic-binary x xs ',name))
+ (vector
+ (fixed-objects-item 'arity-dispatcher-tag)
+ #f
+ (named-lambda (,(symbol 'unary- name) x)
+ (if (not (complex:real? x))
+ (error:wrong-type-argument x "real number" ',name))
+ x)
,generic-binary))))))))
(max/min max complex:max)
(max/min min complex:min))
(case radix
((B) 2)
((O) 8)
- ((D #F) 10)
+ ((D #f) 10)
((X) 16)))))
\ No newline at end of file
(define (debug-internal object)
(let ((dstate (make-initial-dstate object)))
- (with-simple-restart 'CONTINUE "Return from DEBUG."
+ (with-simple-restart 'continue "Return from DEBUG."
(lambda ()
(letter-commands
command-set
(let ((dstate (allocate-dstate)))
(set-dstate/history-state!
dstate
- (cond (debugger:use-history? 'ALWAYS)
- (debugger:auto-toggle? 'ENABLED)
- (else 'DISABLED)))
+ (cond (debugger:use-history? 'always)
+ (debugger:auto-toggle? 'enabled)
+ (else 'disabled)))
(set-dstate/condition! dstate condition)
(set-current-subproblem!
dstate
(else
(error:wrong-type-argument object
"condition or continuation"
- 'DEBUG)))))
+ 'debug)))))
(define (count-subproblems dstate)
(do ((i 0 (1+ i))
(stack-frame/reductions (dstate/subproblem dstate)))
\f
(define (initialize-package!)
- (set! *dstate* (make-unsettable-parameter 'UNBOUND))
- (set! *port* (make-unsettable-parameter 'UNBOUND))
+ (set! *dstate* (make-unsettable-parameter 'unbound))
+ (set! *port* (make-unsettable-parameter 'unbound))
(set!
command-set
(make-command-set
- 'DEBUG-COMMANDS
+ 'debug-commands
`((#\? ,standard-help-command
"help, list command letters")
(#\A ,command/show-all-frames
(cdr form))
(let ((dstate (cadr (cadr form)))
(port (caddr (cadr form))))
- `(DEFINE (,(car (cadr form)) #!OPTIONAL ,dstate ,port)
- (LET ((,dstate (IF (DEFAULT-OBJECT? ,dstate)
- (*DSTATE*)
+ `(define (,(car (cadr form)) #!optional ,dstate ,port)
+ (let ((,dstate (if (default-object? ,dstate)
+ (*dstate*)
,dstate))
- (,port (IF (DEFAULT-OBJECT? ,port) (*PORT*) ,port)))
+ (,port (if (default-object? ,port) (*port*) ,port)))
,@(map (let ((free (list dstate port)))
(lambda (expression)
(make-syntactic-closure environment free
(begin
(newline port)
(let ((arguments (environment-arguments environment)))
- (if (eq? arguments 'UNKNOWN)
+ (if (eq? arguments 'unknown)
(show-environment-bindings environment true port)
(begin
(write-string " applied to: " port)
(if (not thread)
((stack-frame->continuation subproblem) value)
(begin
- (restart-thread thread 'ASK
+ (restart-thread thread 'ask
(lambda ()
((stack-frame->continuation subproblem) value)))
(continue-from-derived-thread-error
(parameterize* (list (cons *dstate* dstate)
(cons *port* port))
(lambda ()
- (debug/read-eval-print (->environment '(RUNTIME DEBUGGER))
+ (debug/read-eval-print (->environment '(runtime debugger))
"the debugger"
"the debugger environment"))))
;;;; Low-level Side-effects
(define (maybe-start-using-history! dstate port)
- (if (eq? 'ENABLED (dstate/history-state dstate))
+ (if (eq? 'enabled (dstate/history-state dstate))
(begin
- (set-dstate/history-state! dstate 'NOW)
+ (set-dstate/history-state! dstate 'now)
(if (not (zero? (dstate/number-of-reductions dstate)))
(debugger-message
port
"Now using information from the execution history.")))))
(define (maybe-stop-using-history! dstate port)
- (if (eq? 'NOW (dstate/history-state dstate))
+ (if (eq? 'now (dstate/history-state dstate))
(begin
- (set-dstate/history-state! dstate 'ENABLED)
+ (set-dstate/history-state! dstate 'enabled)
(if (not (zero? (dstate/number-of-reductions dstate)))
(debugger-message
port
"Now ignoring information from the execution history.")))))
(define (dstate/using-history? dstate)
- (or (eq? 'ALWAYS (dstate/history-state dstate))
- (eq? 'NOW (dstate/history-state dstate))))
+ (or (eq? 'always (dstate/history-state dstate))
+ (eq? 'now (dstate/history-state dstate))))
(define (dstate/auto-toggle? dstate)
- (not (eq? 'DISABLED (dstate/history-state dstate))))
+ (not (eq? 'disabled (dstate/history-state dstate))))
(define (set-current-subproblem! dstate stack-frame previous-frames)
(set-dstate/subproblem! dstate stack-frame)
(cadr reduction))
(define (wrap-around-in-reductions? reductions)
- (or (eq? 'WRAP-AROUND reductions)
+ (or (eq? 'wrap-around reductions)
(and (pair? reductions)
- (eq? 'WRAP-AROUND (cdr (last-pair reductions))))))
+ (eq? 'wrap-around (cdr (last-pair reductions))))))
(define (invalid-expression? expression)
(or (debugging-info/undefined-expression? expression)
(parse/options options
(parse/slot-descriptions (cddr form))
context)))))
- `(BEGIN ,@(type-definitions structure)
+ `(begin ,@(type-definitions structure)
,@(constructor-definitions structure)
,@(accessor-definitions structure)
,@(modifier-definitions structure)
(define (parse/options options slots context)
(let ((options (apply-option-transformers options context)))
- (let ((conc-name-option (find-option 'CONC-NAME options))
- (constructor-options (find-options 'CONSTRUCTOR options))
+ (let ((conc-name-option (find-option 'conc-name options))
+ (constructor-options (find-options 'constructor options))
(keyword-constructor-options
- (find-options 'KEYWORD-CONSTRUCTOR options))
- (copier-option (find-option 'COPIER options))
- (predicate-option (find-option 'PREDICATE options))
- (print-procedure-option (find-option 'PRINT-PROCEDURE options))
- (type-option (find-option 'TYPE options))
- (type-descriptor-option (find-option 'TYPE-DESCRIPTOR options))
- (named-option (find-option 'NAMED options))
- (safe-accessors-option (find-option 'SAFE-ACCESSORS options))
- (initial-offset-option (find-option 'INITIAL-OFFSET options)))
+ (find-options 'keyword-constructor options))
+ (copier-option (find-option 'copier options))
+ (predicate-option (find-option 'predicate options))
+ (print-procedure-option (find-option 'print-procedure options))
+ (type-option (find-option 'type options))
+ (type-descriptor-option (find-option 'type-descriptor options))
+ (named-option (find-option 'named options))
+ (safe-accessors-option (find-option 'safe-accessors options))
+ (initial-offset-option (find-option 'initial-offset options)))
(check-for-duplicate-constructors constructor-options
keyword-constructor-options)
(let ((tagged?
(default-unparser-text context)))
(if type-option
(option/argument type-option)
- 'RECORD)
+ 'record)
tagged?
type-name
(and tagged? tag-expression)
keyword-constructor-options
context)
(let* ((constructors (map option/arguments constructor-options))
- (constructors* (delete '(#F) constructors)))
+ (constructors* (delete '(#f) constructors)))
(cond ((or (pair? keyword-constructor-options)
(pair? constructors*))
constructors*)
- ((member '(#F) constructors) '())
+ ((member '(#f) constructors) '())
(else (list (list (default-constructor-name context)))))))
(define (compute-tagging-info type-descriptor-option named-option context)
(memq object false-expression-names)))
(define false-expression-names
- '(FALSE NIL))
+ '(false nil))
(define (true-marker? object)
(or (eq? #t object)
(memq object true-expression-names)))
(define true-expression-names
- '(TRUE T))
+ '(true t))
(define (option/argument option)
(car (option/arguments option)))
(symbol (parser-context/name context) '-))
(define (default-constructor-name context)
- (symbol 'MAKE- (parser-context/name context)))
+ (symbol 'make- (parser-context/name context)))
(define (default-copier-name context)
- (symbol 'COPY- (parser-context/name context)))
+ (symbol 'copy- (parser-context/name context)))
(define (default-predicate-name context)
(symbol (parser-context/name context) '?))
(define (default-unparser-text context)
- `(,(absolute 'STANDARD-UNPARSER-METHOD context)
+ `(,(absolute 'standard-unparser-method context)
',(parser-context/name context)
- #F))
+ #f))
(define (default-type-name context)
(symbol 'RTD: (parser-context/name context)))
((2) (if-2 (cadr option) (caddr option)))
(else #f)))
\f
-(define-option 'CONC-NAME #f
+(define-option 'conc-name #f
(lambda (option context)
context
(one-required-argument option
(lambda (arg)
- (cond ((false-marker? arg) `(CONC-NAME #F))
- ((symbol? arg) `(CONC-NAME ,arg))
+ (cond ((false-marker? arg) `(conc-name #f))
+ ((symbol? arg) `(conc-name ,arg))
(else #f))))))
-(define-option 'CONSTRUCTOR #t
+(define-option 'constructor #t
(lambda (option context)
(two-optional-arguments option
(lambda ()
- `(CONSTRUCTOR ,(default-constructor-name context)))
+ `(constructor ,(default-constructor-name context)))
(lambda (arg1)
- (cond ((false-expression? arg1 context) `(CONSTRUCTOR #F))
- ((identifier? arg1) `(CONSTRUCTOR ,arg1))
+ (cond ((false-expression? arg1 context) `(constructor #f))
+ ((identifier? arg1) `(constructor ,arg1))
(else #f)))
(lambda (arg1 arg2)
(if (and (identifier? arg1) (mit-lambda-list? arg2))
- `(CONSTRUCTOR ,arg1 ,arg2)
+ `(constructor ,arg1 ,arg2)
#f)))))
-(define-option 'KEYWORD-CONSTRUCTOR #t
+(define-option 'keyword-constructor #t
(lambda (option context)
(one-optional-argument option
(lambda ()
- `(KEYWORD-CONSTRUCTOR ,(default-constructor-name context)))
+ `(keyword-constructor ,(default-constructor-name context)))
(lambda (arg)
(if (identifier? arg)
- `(KEYWORD-CONSTRUCTOR ,arg)
+ `(keyword-constructor ,arg)
#f)))))
-(define-option 'COPIER #f
+(define-option 'copier #f
(lambda (option context)
(one-optional-argument option
(lambda ()
- `(COPIER ,(default-copier-name context)))
+ `(copier ,(default-copier-name context)))
(lambda (arg)
- (cond ((false-expression? arg context) `(COPIER #F))
- ((identifier? arg) `(COPIER ,arg))
+ (cond ((false-expression? arg context) `(copier #f))
+ ((identifier? arg) `(copier ,arg))
(else #f))))))
-(define-option 'PREDICATE #f
+(define-option 'predicate #f
(lambda (option context)
(one-optional-argument option
(lambda ()
- `(PREDICATE ,(default-predicate-name context)))
+ `(predicate ,(default-predicate-name context)))
(lambda (arg)
- (cond ((false-expression? arg context) `(PREDICATE #F))
- ((identifier? arg) `(PREDICATE ,arg))
+ (cond ((false-expression? arg context) `(predicate #f))
+ ((identifier? arg) `(predicate ,arg))
(else #f))))))
\f
-(define-option 'PRINT-PROCEDURE #f
+(define-option 'print-procedure #f
(lambda (option context)
(one-required-argument option
(lambda (arg)
- `(PRINT-PROCEDURE ,(if (false-expression? arg context) #f arg))))))
+ `(print-procedure ,(if (false-expression? arg context) #f arg))))))
-(define-option 'TYPE #f
+(define-option 'type #f
(lambda (option context)
context
(one-required-argument option
(lambda (arg)
- (if (memq arg '(VECTOR LIST))
- `(TYPE ,arg)
+ (if (memq arg '(vector list))
+ `(type ,arg)
#f)))))
-(define-option 'TYPE-DESCRIPTOR #f
+(define-option 'type-descriptor #f
(lambda (option context)
context
(one-required-argument option
(lambda (arg)
(if (identifier? arg)
- `(TYPE-DESCRIPTOR ,arg)
+ `(type-descriptor ,arg)
#f)))))
-(define-option 'NAMED #f
+(define-option 'named #f
(lambda (option context)
(one-optional-argument option
(lambda ()
- `(NAMED))
+ `(named))
(lambda (arg)
- `(NAMED ,(if (false-expression? arg context) #f arg))))))
+ `(named ,(if (false-expression? arg context) #f arg))))))
-(define-option 'SAFE-ACCESSORS #f
+(define-option 'safe-accessors #f
(lambda (option context)
context
(one-optional-argument option
(lambda ()
- `(SAFE-ACCESSORS #T))
+ `(safe-accessors #t))
(lambda (arg)
- (cond ((true-marker? arg) `(SAFE-ACCESSORS #T))
- ((false-marker? arg) `(SAFE-ACCESSORS #F))
+ (cond ((true-marker? arg) `(safe-accessors #t))
+ ((false-marker? arg) `(safe-accessors #f))
(else #f))))))
-(define-option 'INITIAL-OFFSET #f
+(define-option 'initial-offset #f
(lambda (option context)
context
(one-required-argument option
(lambda (arg)
(if (exact-nonnegative-integer? arg)
- `(INITIAL-OFFSET ,arg)
+ `(initial-offset ,arg)
#f)))))
\f
;;;; Parse slot descriptions
(slots structure/slots))
(define-integrable (structure/record-type? structure)
- (eq? (structure/physical-type structure) 'RECORD))
+ (eq? (structure/physical-type structure) 'record))
(define-record-type <parser-context>
(make-parser-context name use-environment closing-environment)
(symbol conc-name name)
name))))
(if (structure/safe-accessors? structure)
- `(DEFINE ,accessor-name
+ `(define ,accessor-name
(,(absolute (case (structure/physical-type structure)
- ((RECORD) 'RECORD-ACCESSOR)
- ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-ACCESSOR)
- ((LIST) 'DEFINE-STRUCTURE/LIST-ACCESSOR))
+ ((record) 'record-accessor)
+ ((vector) 'define-structure/vector-accessor)
+ ((list) 'define-structure/list-accessor))
context)
,(close (structure/type-descriptor structure) context)
',name))
- `(DEFINE-INTEGRABLE (,accessor-name STRUCTURE)
+ `(define-integrable (,accessor-name structure)
(,(absolute (case (structure/physical-type structure)
- ((RECORD) '%RECORD-REF)
- ((VECTOR) 'VECTOR-REF)
- ((LIST) 'LIST-REF))
+ ((record) '%record-ref)
+ ((vector) 'vector-ref)
+ ((list) 'list-ref))
context)
- STRUCTURE
+ structure
,(slot/index slot))))))
(structure/slots structure))))
(modifier-name
(let ((conc-name (structure/conc-name structure)))
(if conc-name
- (symbol 'SET- conc-name name '!)
- (symbol 'SET- name '!)))))
+ (symbol 'set- conc-name name '!)
+ (symbol 'set- name '!)))))
(if (structure/safe-accessors? structure)
- `(DEFINE ,modifier-name
+ `(define ,modifier-name
(,(absolute (case (structure/physical-type structure)
- ((RECORD) 'RECORD-MODIFIER)
- ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-MODIFIER)
- ((LIST) 'DEFINE-STRUCTURE/LIST-MODIFIER))
+ ((record) 'record-modifier)
+ ((vector) 'define-structure/vector-modifier)
+ ((list) 'define-structure/list-modifier))
context)
,(close (structure/type-descriptor structure) context)
',name))
- `(DEFINE-INTEGRABLE (,modifier-name STRUCTURE VALUE)
+ `(define-integrable (,modifier-name structure value)
,(case (structure/physical-type structure)
- ((RECORD)
- `(,(absolute '%RECORD-SET! context) STRUCTURE
+ ((record)
+ `(,(absolute '%record-set! context) structure
,(slot/index slot)
- VALUE))
- ((VECTOR)
- `(,(absolute 'VECTOR-SET! context) STRUCTURE
+ value))
+ ((vector)
+ `(,(absolute 'vector-set! context) structure
,(slot/index slot)
- VALUE))
- ((LIST)
- `(,(absolute 'SET-CAR! context)
- (,(absolute 'LIST-TAIL context) STRUCTURE
+ value))
+ ((list)
+ `(,(absolute 'set-car! context)
+ (,(absolute 'list-tail context) structure
,(slot/index slot))
- VALUE)))))))
+ value)))))))
(delete-matching-items (structure/slots structure) slot/read-only?))))
\f
(define (constructor-definitions structure)
(structure/constructors structure))
,@(let ((context (structure/context structure)))
(let ((p (absolute (if (structure/record-type? structure)
- 'RECORD-KEYWORD-CONSTRUCTOR
- 'DEFINE-STRUCTURE/KEYWORD-CONSTRUCTOR)
+ 'record-keyword-constructor
+ 'define-structure/keyword-constructor)
context))
(t (close (structure/type-descriptor structure) context)))
- (map (lambda (constructor) `(DEFINE ,(car constructor) (,p ,t)))
+ (map (lambda (constructor) `(define ,(car constructor) (,p ,t)))
(structure/keyword-constructors structure))))))
(define (constructor-definition/boa structure name lambda-list)
(lambda (tag-expression)
(let ((context (structure/context structure)))
`(,(absolute (case (structure/physical-type structure)
- ((RECORD) '%RECORD)
- ((VECTOR) 'VECTOR)
- ((LIST) 'LIST))
+ ((record) '%record)
+ ((vector) 'vector)
+ ((list) 'list))
context)
,@(if (structure/tagged? structure) `(,tag-expression) '())
- ,@(make-list (structure/offset structure) '#F)
+ ,@(make-list (structure/offset structure) '#f)
,@(call-with-values (lambda () (parse-mit-lambda-list lambda-list))
(lambda (required optional rest)
(let ((name->slot
(eq? slot rest))
name)
((memq slot optional)
- `(IF (DEFAULT-OBJECT? ,name) ,dv ,name))
+ `(if (default-object? ,name) ,dv ,name))
(else dv))))
(structure/slots structure)))))))))))
\f
(let* ((context (structure/context structure))
(tag-expression (close (structure/tag-expression structure) context)))
(if (structure/record-type? structure)
- `(DEFINE ,name
- (LET ((TAG ,tag-expression))
+ `(define ,name
+ (let ((tag ,tag-expression))
,(capture-syntactic-environment
(lambda (environment)
- `(NAMED-LAMBDA (,name ,@lambda-list)
- ,(generate-body (close-syntax 'TAG environment)))))))
- `(DEFINE (,name ,@lambda-list)
+ `(named-lambda (,name ,@lambda-list)
+ ,(generate-body (close-syntax 'tag environment)))))))
+ `(define (,name ,@lambda-list)
,(generate-body tag-expression)))))
(define (default-value-expr structure slot)
(let ((record? (structure/record-type? structure))
(context (structure/context structure)))
`(,(absolute (if record?
- 'RECORD-TYPE-DEFAULT-VALUE-BY-INDEX
- 'DEFINE-STRUCTURE/DEFAULT-VALUE-BY-INDEX)
+ 'record-type-default-value-by-index
+ 'define-structure/default-value-by-index)
context)
,(close (structure/type-descriptor structure) context)
,(- (slot/index slot)
(define (copier-definitions structure)
(let ((copier-name (structure/copier structure)))
(if copier-name
- `((DEFINE ,copier-name
+ `((define ,copier-name
,(absolute (case (structure/physical-type structure)
- ((RECORD) 'COPY-RECORD)
- ((VECTOR) 'VECTOR-COPY)
- ((LIST) 'LIST-COPY))
+ ((record) 'copy-record)
+ ((vector) 'vector-copy)
+ ((list) 'list-copy))
(structure/context structure))))
'())))
(define (make-dos-host-type index)
(make-host-type index
- 'DOS
+ 'dos
dos/parse-namestring
dos/pathname->namestring
dos/make-pathname
dos/pathname-simplify))
(define (initialize-package!)
- (add-pathname-host-type! 'DOS make-dos-host-type))
+ (add-pathname-host-type! 'dos make-dos-host-type))
\f
;;;; Pathname Parser
(and (not (null? components))
(simplify-directory
(if (fix:= 0 (string-length (car components)))
- (cons 'ABSOLUTE
+ (cons 'absolute
(if (and (pair? (cdr components))
(fix:= 0
(string-length
(cddr components)))
(parse-directory-components
(cdr components))))
- (cons 'RELATIVE
+ (cons 'relative
(parse-directory-components components))))))
name
type
- 'UNSPECIFIC))))))
+ 'unspecific))))))
(define (expand-directory-prefixes components)
(let ((string (car components))
(values #f components))))
(define (simplify-directory directory)
- (cond ((and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) #f)
- ((equal? '(ABSOLUTE UP) directory) '(ABSOLUTE))
+ (cond ((and (eq? (car directory) 'relative) (null? (cdr directory))) #f)
+ ((equal? '(absolute up) directory) '(absolute))
(else directory)))
(define (parse-directory-components components)
(define (parse-directory-component component)
(if (string=? ".." component)
- 'UP
+ 'up
component))
(define (string-components string delimiters)
(fix:= dot (fix:- end 1))
(char=? #\. (string-ref string (fix:- dot 1))))
(values (cond ((fix:= end 0) #f)
- ((string=? "*" string) 'WILD)
+ ((string=? "*" string) 'wild)
(else string))
#f)
(values (extract string 0 dot)
(define (extract string start end)
(if (and (fix:= 1 (fix:- end start))
(char=? #\* (string-ref string start)))
- 'WILD
+ 'wild
(substring string start end)))
\f
;;;; Pathname Unparser
(%pathname-type pathname))))
(define (unparse-device device)
- (if (or (not device) (eq? device 'UNSPECIFIC))
+ (if (or (not device) (eq? device 'unspecific))
""
(string-append device ":")))
(define (unparse-directory directory)
- (cond ((or (not directory) (eq? directory 'UNSPECIFIC))
+ (cond ((or (not directory) (eq? directory 'unspecific))
"")
((pair? directory)
(string-append
- (if (eq? (car directory) 'ABSOLUTE)
+ (if (eq? (car directory) 'absolute)
sub-directory-delimiter-string
"")
(let loop ((directory (cdr directory)))
(error:illegal-pathname-component directory "directory"))))
(define (unparse-directory-component component)
- (cond ((eq? component 'UP) "..")
+ (cond ((eq? component 'up) "..")
((string? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
(define (unparse-component component)
(cond ((or (not component) (string? component)) component)
- ((eq? component 'WILD) "*")
+ ((eq? component 'wild) "*")
(else (error:illegal-pathname-component component "component"))))
\f
;;;; Pathname Constructors
(%%make-pathname
host
(cond ((string? device) device)
- ((memq device '(#F UNSPECIFIC)) device)
+ ((memq device '(#f unspecific)) device)
(else (error:illegal-pathname-component device "device")))
- (cond ((or (not directory) (eq? directory 'UNSPECIFIC))
+ (cond ((or (not directory) (eq? directory 'unspecific))
directory)
((and (list? directory)
(not (null? directory))
- (memq (car directory) '(RELATIVE ABSOLUTE))
+ (memq (car directory) '(relative absolute))
(every (lambda (element)
(if (string? element)
(not (fix:= 0 (string-length element)))
- (eq? element 'UP)))
+ (eq? element 'up)))
(if (server-directory? directory)
(cddr directory)
(cdr directory))))
(simplify-directory directory))
(else
(error:illegal-pathname-component directory "directory")))
- (if (or (memq name '(#F WILD))
+ (if (or (memq name '(#f wild))
(and (string? name) (not (fix:= 0 (string-length name)))))
name
(error:illegal-pathname-component name "name"))
- (if (or (memq type '(#F WILD))
+ (if (or (memq type '(#f wild))
(and (string? type) (not (fix:= 0 (string-length type)))))
type
(error:illegal-pathname-component type "type"))
- (if (memq version '(#F UNSPECIFIC WILD NEWEST))
- 'UNSPECIFIC
+ (if (memq version '(#f unspecific wild newest))
+ 'unspecific
(error:illegal-pathname-component version "version"))))
(define (%%make-pathname host device directory name type version)
;; because doing so is a more pervasive change. Until someone has
;; the energy to fix it correctly, this will have to do.
(%make-pathname host
- (if (server-directory? directory) 'UNSPECIFIC device)
+ (if (server-directory? directory) 'unspecific device)
directory
name
type
(define (server-directory? directory)
(and (pair? directory)
- (eq? (car directory) 'ABSOLUTE)
+ (eq? (car directory) 'absolute)
(pair? (cdr directory))
(string? (cadr directory))
(fix:= 0 (string-length (cadr directory)))))
(%pathname-directory pathname)
#f
#f
- 'UNSPECIFIC))
+ 'unspecific))
(define (dos/file-pathname pathname)
(%%make-pathname (%pathname-host pathname)
(let ((directory (%pathname-directory pathname))
(component
(parse-directory-component (unparse-name name type))))
- (cond ((not (pair? directory)) (list 'RELATIVE component))
+ (cond ((not (pair? directory)) (list 'relative component))
((equal? component ".") directory)
(else (append directory (list component))))))
#f
#f
- 'UNSPECIFIC)
+ 'unspecific)
pathname)))
(define (dos/directory-pathname-as-file pathname)
(let ((directory (%pathname-directory pathname)))
(if (not (and (pair? directory)
- (or (eq? 'ABSOLUTE (car directory))
+ (or (eq? 'absolute (car directory))
(pair? (cdr directory)))))
- (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE))
+ (error:bad-range-argument pathname 'directory-pathname-as-file))
(if (or (%pathname-name pathname)
(%pathname-type pathname)
(null? (cdr directory)))
(simplify-directory (except-last-pair directory))
name
type
- 'UNSPECIFIC))))))
+ 'unspecific))))))
\f
;;;; Miscellaneous
'()
(let ((head (car elements))
(tail (loop (cdr elements))))
- (if (and (eq? head 'UP)
+ (if (and (eq? head 'up)
(not (null? tail))
- (not (eq? (car tail) 'UP)))
+ (not (eq? (car tail) 'up)))
(cdr tail)
(cons head tail)))))))))
(and (not (equal? directory directory*))
modifiers ;ignore
(format-loop port
(substring string
- (1+ (string-find-next-char string #\Newline))
+ (1+ (string-find-next-char string #\newline))
(string-length string))
arguments))
(define ((format-ignore-whitespace modifiers) port string arguments)
(format-loop port
(cond ((null? modifiers) (eliminate-whitespace string))
- ((memq 'AT modifiers)
+ ((memq 'at modifiers)
(string-append "\n" (eliminate-whitespace string)))
(else string))
arguments))
(cond ((= n limit) "")
((let ((char (string-ref string n)))
(and (char-whitespace? char)
- (not (char=? char #\Newline))))
+ (not (char=? char #\newline))))
(loop (1+ n)))
(else
(substring string n limit))))))
(if (default-object? n-columns)
(write (car arguments) port)
(output-port/write-string port
- ((if (memq 'AT modifiers)
+ ((if (memq 'at modifiers)
string-pad-left
string-pad-right)
(call-with-output-string
(#\# ,parse-arity)
(#\V ,parse-argument)
(#\v ,parse-argument)
- (#\@ ,(parse-modifier 'AT))
- (#\: ,(parse-modifier 'COLON))
+ (#\@ ,(parse-modifier 'at))
+ (#\: ,(parse-modifier 'colon))
(#\%
,(format-wrapper (format-insert-character #\newline)))
(#\~ ,(format-wrapper (format-insert-character #\~)))
unspecific)
(define (set-gc-notification! #!optional on?)
- (let ((on? (if (default-object? on?) #T on?)))
+ (let ((on? (if (default-object? on?) #t on?)))
(if on?
(register-gc-event gc-notification)
(deregister-gc-event))
(let ((thread (weak-car weak)))
(and thread
(weak-cdr weak) ;not cleared by %deregister...
- (not (eq? 'DEAD (thread-execution-state thread))))))
+ (not (eq? 'dead (thread-execution-state thread))))))
gc-events)))
(define (registered-gc-event)
(signaled? #f))
(define (signal-event thread event)
- (if (and thread (not (eq? 'DEAD (thread-execution-state thread))))
+ (if (and thread (not (eq? 'dead (thread-execution-state thread))))
(begin
(%signal-thread-event thread event)
(set! signaled? #t))))
(define (opt-writer? object)
(and (pair? object)
- (eq? (car object) 'OPT-WRITER)))
+ (eq? (car object) 'opt-writer)))
(define ((alt-writer predicate consequent alternative) value port)
((if (predicate value) consequent alternative) value port))
(define-guarantee http-header "HTTP header field")
(define-unparser-method http-header?
- (simple-unparser-method 'HTTP-HEADER
+ (simple-unparser-method 'http-header
(lambda (header)
(list (http-header-name header)))))
(define (make-http-header name value)
- (guarantee http-token? name 'MAKE-HTTP-HEADER)
+ (guarantee http-token? name 'make-http-header)
(let ((defn (header-value-defn name)))
(if defn
(if ((hvdefn-predicate defn) value)
((hvdefn-writer defn) value port)))
value)
(begin
- (guarantee http-text? value 'MAKE-HTTP-HEADER)
+ (guarantee http-text? value 'make-http-header)
(%make-header name value
(%call-parser (hvdefn-parser defn) value #t))))
(begin
- (guarantee http-text? value 'MAKE-HTTP-HEADER)
+ (guarantee http-text? value 'make-http-header)
(%make-header name value (%unparsed-value))))))
(define (convert-http-headers headers #!optional caller)
(eq? (http-header-name header) name))
headers)))
(if (and (not h) error?)
- (error:bad-range-argument name 'HTTP-HEADER))
+ (error:bad-range-argument name 'http-header))
h))
\f
;;;; Tokens and text
(default-object))
(define (write-http-headers headers port)
- (guarantee-list-of http-header? headers 'WRITE-HTTP-HEADERS)
+ (guarantee-list-of http-header? headers 'write-http-headers)
(for-each (lambda (header)
(let ((name (http-header-name header)))
(let ((defn (header-value-defn name)))
(list-parser (qualify bytes-unit? lp:token)))
(define bytes-unit?
- (token-predicate 'BYTES))
+ (token-predicate 'bytes))
(define write-bytes-unit
- (token-writer 'BYTES))
+ (token-writer 'bytes))
(define byte-range-spec?
(joined-predicate (pair-predicate (opt-predicate exact-nonnegative-integer?)
token)
(define quoted-string-token?
- (pair-predicate (token-predicate 'QUOTED-STRING)
+ (pair-predicate (token-predicate 'quoted-string)
string?))
(define (quoted-string-token->string token)
(cdr token))
(define comment-token?
- (pair-predicate (token-predicate 'COMMENT)
+ (pair-predicate (token-predicate 'comment)
string?))
(define (comment-token->string token)
(cdr form))
(let loop ((clauses (cddr form)))
(and (pair? clauses)
- (if (eq? (caar clauses) 'ELSE)
+ (if (eq? (caar clauses) 'else)
(null? (cdr clauses))
(loop (cdr clauses))))))
(let ((state (cadr form))
(define (compile-rhs clause vars)
(let ((rhs (cdr clause)))
- `(LAMBDA (,@vars PORT EMIT FIFO)
- (DECLARE (IGNORABLE ,@vars PORT EMIT FIFO))
+ `(lambda (,@vars port emit fifo)
+ (declare (ignorable ,@vars port emit fifo))
,@(map compile-action (except-last-pair rhs))
,(let ((ns (last rhs)))
- (cond ((eq? ns 'DONE)
- '(EMIT))
+ (cond ((eq? ns 'done)
+ '(emit))
((symbol? ns)
- `(,(state->name ns) PORT EMIT FIFO))
+ `(,(state->name ns) port emit fifo))
(else ns))))))
(define (compile-action action)
- (cond ((eq? action 'SAVE-CHAR) '(FIFO CHAR))
- ((eq? action 'UNREAD-CHAR) '(UNREAD-CHAR CHAR PORT))
+ (cond ((eq? action 'save-char) '(fifo char))
+ ((eq? action 'unread-char) '(unread-char char port))
(else action)))
(define (state->name name)
- (symbol 'TOKENIZER-STATE: name))
+ (symbol 'tokenizer-state: name))
- `(DEFINE-DEFERRED ,(state->name state)
- (MAKE-STATE ,(if eof-clause
+ `(define-deferred ,(state->name state)
+ (make-state ,(if eof-clause
(compile-rhs eof-clause '())
- `#F)
- ,(compile-rhs else-clause '(CHAR))
+ `#f)
+ ,(compile-rhs else-clause '(char))
,@(append-map (lambda (clause)
`(,(car clause)
- ,(compile-rhs clause '(CHAR))))
+ ,(compile-rhs clause '(char))))
normal-clauses))))
(ill-formed-syntax form)))))
(eof (error "Premature EOF in quoted string."))
(char-set:http-qdtext save-char in-quoted-string)
(#\\ in-quoted-string-quotation)
- (#\" (emit (cons 'QUOTED-STRING (fifo))) tokenize)
+ (#\" (emit (cons 'quoted-string (fifo))) tokenize)
(else (error "Illegal char in quoted string:" char)))
(define-tokenizer-state in-quoted-string-quotation
((char=? char #\))
(if (= level 1)
(begin
- (emit (cons 'COMMENT (fifo)))
+ (emit (cons 'comment (fifo)))
(tokenizer-state:tokenize port emit fifo))
(begin
(fifo char)
(define-header "Accept-Ranges"
(tokenized-parser
- (let ((none? (token-predicate 'NONE)))
+ (let ((none? (token-predicate 'none)))
(list-parser
(alt (encapsulate (lambda (none) none '())
(qualify none? lp:token))
lp:token+))))
(list-predicate http-token?)
(alt-writer null?
- (token-writer 'NONE)
+ (token-writer 'none)
write-tokens))
(define-header "Age"
(set! xlambda-unwrapped-body unwrapped-body)
(set! set-xlambda-unwrapped-body! set-unwrapped-body!)))
(set! &lambda-components
- (dispatch-1 'LAMBDA-COMPONENTS
+ (dispatch-1 'lambda-components
clambda-components
xlambda-components))
(set! has-internal-lambda?
- (dispatch-0 'HAS-INTERNAL-LAMBDA?
+ (dispatch-0 'has-internal-lambda?
clambda-has-internal-lambda?
xlambda-has-internal-lambda?))
(set! lambda-arity
- (dispatch-1 'LAMBDA-ARITY
+ (dispatch-1 'lambda-arity
slambda-arity
xlambda-arity))
(set! scode-lambda-body
clambda-bound?
xlambda-bound?))
(set! lambda-immediate-body
- (dispatch-0 'LAMBDA-IMMEDIATE-BODY
+ (dispatch-0 'lambda-immediate-body
slambda-body
xlambda-body))
(set! scode-lambda-interface
slambda-name
xlambda-name))
(set! lambda-names-vector
- (dispatch-0 'LAMBDA-NAMES-VECTOR
+ (dispatch-0 'lambda-names-vector
slambda-names-vector
xlambda-names-vector))
(set! lambda-unwrap-body!
- (dispatch-0 'LAMBDA-UNWRAP-BODY!
+ (dispatch-0 'lambda-unwrap-body!
clambda-unwrap-body!
xlambda-unwrap-body!))
(set! lambda-wrap-body!
- (dispatch-1 'LAMBDA-WRAP-BODY!
+ (dispatch-1 'lambda-wrap-body!
clambda-wrap-body!
xlambda-wrap-body!))
(set! lambda-wrapper-components
- (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS
+ (dispatch-1 'lambda-wrapper-components
clambda-wrapper-components
xlambda-wrapper-components))
(set! set-scode-lambda-body!
(define (clambda-components clambda receiver)
(slambda-components clambda
(lambda (name required body)
- (receiver name required '() '#F ;;! '()
+ (receiver name required '() '#f
(lambda-body-auxiliary body)
(clambda-unwrapped-body clambda)))))
(subvector->list bound ostart rstart)
(if rest?
(vector-ref bound rstart)
- #F) ;;!'()
+ #f)
(append
(subvector->list bound astart (vector-length bound))
(lambda-body-auxiliary (&triple-first xlambda)))
(let ((body*
(if (null? declarations)
body
- (make-scode-sequence (list (make-scode-block-declaration declarations)
- body)))))
+ (make-scode-sequence
+ (list (make-scode-block-declaration declarations)
+ body)))))
(cond ((and (< (length required) 256)
(< (length optional) 256)
(or (not (null? optional))
rest))
(make-xlambda name required optional rest auxiliary body*))
((not (null? optional))
- (error "Optionals not implemented" 'MAKE-LAMBDA))
+ (error "Optionals not implemented" 'make-lambda))
(rest
(error "You want how many arguments? AND a rest arg?"))
(else
(define (compiled-expression? object)
(and (compiled-code-address? object)
- (eq? (compiled-entry-type object) 'COMPILED-EXPRESSION)))
+ (eq? (compiled-entry-type object) 'compiled-expression)))
(define (compiled-return-address? object)
(and (compiled-code-address? object)
- (eq? (compiled-entry-type object) 'COMPILED-RETURN-ADDRESS)))
+ (eq? (compiled-entry-type object) 'compiled-return-address)))
(define-primitives
(stack-address-offset 1)
(define (compiled-entry-type entry)
(case (system-hunk3-cxr0 ((ucode-primitive compiled-entry-kind 1) entry))
- ((0) 'COMPILED-PROCEDURE)
- ((1) 'COMPILED-RETURN-ADDRESS)
- ((2) 'COMPILED-EXPRESSION)
- (else 'COMPILED-ENTRY)))
+ ((0) 'compiled-procedure)
+ ((1) 'compiled-return-address)
+ ((2) 'compiled-expression)
+ (else 'compiled-entry)))
(define (compiled-continuation/next-continuation-offset entry)
(let ((offset
(- (system-vector-length block) 2))
(define (compiled-code-block/debugging-info? block)
- (not (memq (compiled-code-block/debugging-info block) '(#F DEBUGGING-INFO))))
+ (not (memq (compiled-code-block/debugging-info block) '(#f debugging-info))))
(define (compiled-code-block/debugging-info block)
(system-vector-ref block (- (system-vector-length block) 2)))
(system-pair-car promise))
(define (force promise)
- (guarantee promise? promise 'FORCE)
+ (guarantee promise? promise 'force)
(case (system-pair-car promise)
- ((#T)
+ ((#t)
(system-pair-cdr promise))
((0) ;compiled promise
(let ((result ((system-pair-cdr promise))))
(lambda (continuation . field-values)
(error (apply make-condition
(cons* continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
field-values))))))
(define (initialize-error-hooks!)
;;;; Restart Bindings
(define (unbound-variable/store-value continuation environment name thunk)
- (with-restart 'STORE-VALUE
+ (with-restart 'store-value
(lambda (port)
(write-string "Define " port)
(write name port)
thunk))
(define (unassigned-variable/store-value continuation environment name thunk)
- (with-restart 'STORE-VALUE
+ (with-restart 'store-value
(lambda (port)
(write-string "Set " port)
(write name port)
(define (variable/use-value continuation environment name thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if (continuation-restartable? continuation)
- (with-restart 'USE-VALUE
+ (with-restart 'use-value
(lambda (port)
(write-string "Specify a value to use instead of " port)
(write name port)
(define (inapplicable-object/use-value continuation operands thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if (continuation-restartable? continuation)
- (with-restart 'USE-VALUE "Specify a procedure to use in its place."
+ (with-restart 'use-value "Specify a procedure to use in its place."
(lambda (operator)
(within-continuation continuation
(lambda ()
(thunk))))
\f
(define (illegal-arg-signaller type)
- (let ((signal (condition-signaller type '(DATUM OPERATOR OPERAND))))
+ (let ((signal (condition-signaller type '(datum operator operand))))
(lambda (continuation operator operands index)
(illegal-argument/use-value continuation operator operands index
(lambda ()
(let ((continuation
(continuation/next-continuation/no-compiled-code continuation)))
(if (continuation-restartable? continuation)
- (with-restart 'USE-VALUE "Specify an argument to use in its place."
+ (with-restart 'use-value "Specify an argument to use in its place."
(lambda (operand)
(within-continuation continuation
(lambda ()
(define (file-operation-signaller)
(let ((signal
(condition-signaller condition-type:file-operation-error
- '(FILENAME VERB NOUN REASON OPERATOR OPERANDS))))
+ '(filename verb noun reason operator operands))))
(lambda (continuation operator operands index verb noun reason)
(file-operation/use-value continuation operator operands index verb noun
(lambda ()
verb noun thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if (continuation-restartable? continuation)
- (with-restart 'USE-VALUE
+ (with-restart 'use-value
(string-append "Try to " verb " a different " noun ".")
(lambda (operand)
(within-continuation continuation
(define (file-operation/retry continuation operator operands verb noun thunk)
(let ((continuation (continuation/next-continuation continuation)))
(if (continuation-restartable? continuation)
- (with-restart 'RETRY
+ (with-restart 'retry
(string-append "Try to " verb " the same " noun " again.")
(lambda ()
(within-continuation continuation
(let ((further-subproblem
(stack-frame/next next-subproblem)))
(stack-frame/compiled-code? further-subproblem)))
- #F
+ #f
(stack-frame->continuation next-subproblem)))))))
(define (continuation-restartable? continuation)
(define (normalize-trap-code-name name)
(cond ((or (string-prefix-ci? "integer divide by 0" name)
(string-prefix-ci? "integer divide by zero" name))
- 'INTEGER-DIVIDE-BY-ZERO)
+ 'integer-divide-by-zero)
((or (string-prefix-ci? "floating-point divide by 0" name)
(string-prefix-ci? "floating-point divide by zero" name))
- 'FLOATING-POINT-DIVIDE-BY-ZERO)
+ 'floating-point-divide-by-zero)
((or (string-prefix-ci? "divide by 0" name)
(string-prefix-ci? "divide by zero" name))
- 'DIVIDE-BY-ZERO)
+ 'divide-by-zero)
((or (string-prefix-ci? "inexact result" name)
(string-prefix-ci? "inexact operation" name)
(string-prefix-ci? "floating-point inexact result" name))
- 'INEXACT-RESULT)
+ 'inexact-result)
((or (string-prefix-ci? "invalid operation" name)
(string-prefix-ci? "invalid floating-point operation" name))
- 'INVALID-OPERATION)
+ 'invalid-operation)
((or (string-prefix-ci? "overflow" name)
(string-prefix-ci? "floating-point overflow" name))
- 'OVERFLOW)
+ 'overflow)
((or (string-prefix-ci? "underflow" name)
(string-prefix-ci? "floating-point underflow" name))
- 'UNDERFLOW)
+ 'underflow)
(else #f)))
\f
(define (file-primitive-description primitive)
(define (initialize-package!)
(set! return-code:internal-apply
- (microcode-return/name->code 'INTERNAL-APPLY))
+ (microcode-return/name->code 'internal-apply))
(set! return-code:internal-apply-val
- (microcode-return/name->code 'INTERNAL-APPLY-VAL))
+ (microcode-return/name->code 'internal-apply-val))
(set! return-code:pop-return-error
- (microcode-return/name->code 'POP-RETURN-ERROR))
+ (microcode-return/name->code 'pop-return-error))
(set! return-code:compiler-error-restart
- (microcode-return/name->code 'COMPILER-ERROR-RESTART))
+ (microcode-return/name->code 'compiler-error-restart))
(set! error-handler-vector
(make-vector (microcode-error/code-limit)
(default-error-handler continuation error-code))))))
(set! condition-type:anomalous-microcode-error
- (make-condition-type 'ANOMALOUS-MICROCODE-ERROR condition-type:error
- '(ERROR-CODE EXTRA)
+ (make-condition-type 'anomalous-microcode-error condition-type:error
+ '(error-code extra)
(lambda (condition port)
(write-string "Anomalous microcode error " port)
- (write (access-condition condition 'ERROR-CODE) port)
+ (write (access-condition condition 'error-code) port)
(write-string " -- get a wizard." port))))
(set! default-error-handler
(let ((signal
(condition-signaller condition-type:anomalous-microcode-error
- '(ERROR-CODE EXTRA))))
+ '(error-code extra))))
(lambda (continuation error-code)
(let ((doit
(lambda (error-code extra)
(set! unknown-error-names '())
-(define-low-level-handler 'ERROR-WITH-ARGUMENT
+(define-low-level-handler 'error-with-argument
(lambda (continuation argument)
((if (and (vector? argument)
(fix:>= (vector-length argument) 1)
(eqv? (vector-ref argument 0)
- (microcode-error/name->code 'SYSTEM-CALL)))
+ (microcode-error/name->code 'system-call)))
system-call-error-handler
default-error-handler)
continuation
\f
;;;; Variable Errors
-(define-error-handler 'UNBOUND-VARIABLE
+(define-error-handler 'unbound-variable
(let ((signal
(condition-signaller condition-type:unbound-variable
- '(ENVIRONMENT LOCATION))))
+ '(environment location))))
(lambda (continuation)
(signal-variable-error
continuation
(lambda ()
(signal continuation environment name))))))))
-(define-error-handler 'UNASSIGNED-VARIABLE
+(define-error-handler 'unassigned-variable
(let ((signal
(condition-signaller condition-type:unassigned-variable
- '(ENVIRONMENT LOCATION))))
+ '(environment location))))
(lambda (continuation)
(signal-variable-error
continuation
environment name
unspecific)))))
-(define-error-handler 'MACRO-BINDING
+(define-error-handler 'macro-binding
(let ((signal
(condition-signaller condition-type:macro-binding
- '(ENVIRONMENT LOCATION))))
+ '(environment location))))
(lambda (continuation)
(signal-variable-error
continuation
(apply-frame/operands frame)
n))))))
-(define-arg-error 'BAD-RANGE-ARGUMENT-0 0 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-1 1 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-2 2 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-3 3 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-4 4 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-5 5 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-6 6 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-7 7 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-8 8 signal-bad-range-argument)
-(define-arg-error 'BAD-RANGE-ARGUMENT-9 9 signal-bad-range-argument)
-
-(define-arg-error 'WRONG-TYPE-ARGUMENT-0 0 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-1 1 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-2 2 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-3 3 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-4 4 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-5 5 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-6 6 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-7 7 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-8 8 signal-wrong-type-argument)
-(define-arg-error 'WRONG-TYPE-ARGUMENT-9 9 signal-wrong-type-argument)
+(define-arg-error 'bad-range-argument-0 0 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-1 1 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-2 2 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-3 3 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-4 4 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-5 5 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-6 6 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-7 7 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-8 8 signal-bad-range-argument)
+(define-arg-error 'bad-range-argument-9 9 signal-bad-range-argument)
+
+(define-arg-error 'wrong-type-argument-0 0 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-1 1 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-2 2 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-3 3 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-4 4 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-5 5 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-6 6 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-7 7 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-8 8 signal-wrong-type-argument)
+(define-arg-error 'wrong-type-argument-9 9 signal-wrong-type-argument)
\f
;;;; Primitive Errors
(define (define-primitive-error error-name type)
(define-error-handler error-name
- (let ((signal (condition-signaller type '(OPERATOR OPERANDS))))
+ (let ((signal (condition-signaller type '(operator operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(apply-frame/operands frame))))))))))
(set! condition-type:primitive-procedure-error
- (make-condition-type 'PRIMITIVE-PROCEDURE-ERROR condition-type:error
- '(OPERATOR OPERANDS)
+ (make-condition-type 'primitive-procedure-error condition-type:error
+ '(operator operands)
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " signalled an anonymous error." port))))
-(define-primitive-error 'EXTERNAL-RETURN
+(define-primitive-error 'external-return
condition-type:primitive-procedure-error)
(set! condition-type:unimplemented-primitive
- (make-condition-type 'UNIMPLEMENTED-PRIMITIVE
+ (make-condition-type 'unimplemented-primitive
condition-type:primitive-procedure-error
'()
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " is not implemented in this version of Scheme." port))))
-(define-primitive-error 'UNIMPLEMENTED-PRIMITIVE
+(define-primitive-error 'unimplemented-primitive
condition-type:unimplemented-primitive)
(set! condition-type:unimplemented-primitive-for-os
- (make-condition-type 'UNIMPLEMENTED-PRIMITIVE-FOR-OS
+ (make-condition-type 'unimplemented-primitive-for-os
condition-type:unimplemented-primitive
'()
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " is not implemented for this operating system." port))))
(define-primitive-error 'UNDEFINED-PRIMITIVE-OPERATION
condition-type:unimplemented-primitive-for-os)
(set! condition-type:compiled-code-error
- (make-condition-type 'COMPILED-CODE-ERROR
+ (make-condition-type 'compiled-code-error
condition-type:primitive-procedure-error
'()
(lambda (condition port)
(write-string "The open-coded primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " was called with an inappropriate argument." port))))
-(define-error-handler 'COMPILED-CODE-ERROR
+(define-error-handler 'compiled-code-error
(let ((signal
(condition-signaller condition-type:compiled-code-error
- '(OPERATOR OPERANDS))))
+ '(operator operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (compiled-code-error-frame? frame)
(let ((irritant (compiled-code-error-frame/irritant frame)))
(if (primitive-procedure? irritant)
- (signal continuation irritant 'UNKNOWN))))))))
+ (signal continuation irritant 'unknown))))))))
\f
(set! condition-type:primitive-io-error
;; Primitives that signal this error should be changed to signal a
;; system-call error instead, since that is more descriptive.
- (make-condition-type 'PRIMITIVE-IO-ERROR
+ (make-condition-type 'primitive-io-error
condition-type:primitive-procedure-error
'()
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " signalled an anonymous I/O error." port))))
(set! condition-type:out-of-file-handles
- (make-condition-type 'OUT-OF-FILE-HANDLES
+ (make-condition-type 'out-of-file-handles
condition-type:primitive-procedure-error
'()
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " could not allocate a channel or subprocess." port))))
-(define-error-handler 'OUT-OF-FILE-HANDLES
+(define-error-handler 'out-of-file-handles
(let ((signal
(condition-signaller condition-type:out-of-file-handles
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-file-operation (file-operation-signaller)))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
;++ in the subprocess GC finalizer, and I'm lazy.
(set! condition-type:process-terminated-error
- (make-condition-type 'PROCESS-TERMINATED
+ (make-condition-type 'process-terminated
condition-type:primitive-procedure-error
'()
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string " was given a process that has terminated."))))
-(define-primitive-error 'PROCESS-TERMINATED
+(define-primitive-error 'process-terminated
condition-type:process-terminated-error)
\f
(set! condition-type:system-call-error
- (make-condition-type 'SYSTEM-CALL-ERROR
+ (make-condition-type 'system-call-error
condition-type:primitive-procedure-error
- '(SYSTEM-CALL ERROR-TYPE)
+ '(system-call error-type)
(lambda (condition port)
(write-string "The primitive " port)
- (write-operator (access-condition condition 'OPERATOR) port)
+ (write-operator (access-condition condition 'operator) port)
(write-string ", while executing " port)
- (let ((system-call (access-condition condition 'SYSTEM-CALL)))
+ (let ((system-call (access-condition condition 'system-call)))
(if (symbol? system-call)
(begin
(write-string "the " port)
(write-string "system call " port)
(write system-call port))))
(write-string ", received " port)
- (let ((error-type (access-condition condition 'ERROR-TYPE)))
+ (let ((error-type (access-condition condition 'error-type)))
(if (or (symbol? error-type) (string? error-type))
(write-string "the error: " port))
(write-string (error-type->string error-type) port))
(define system-call-error-handler
(let ((make-condition
(condition-constructor condition-type:system-call-error
- '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))
+ '(operator operands system-call error-type)))
(signal-file-operation (file-operation-signaller)))
(lambda (continuation error-code)
(let ((frame (continuation/first-subproblem continuation)))
error-type)))))
(let ((make-condition
(lambda ()
- (make-condition continuation 'BOUND-RESTARTS
+ (make-condition continuation 'bound-restarts
operator operands
system-call error-type))))
(cond ((port-error-test operator operands)
(else
(error (make-condition)))))))))))
-(define-low-level-handler 'SYSTEM-CALL system-call-error-handler)
+(define-low-level-handler 'system-call system-call-error-handler)
\f
;;;; FASLOAD Errors
(define (define-fasload-error error-code type)
(define-error-handler error-code
- (let ((signal (condition-signaller type '(FILENAME OPERATOR OPERANDS))))
+ (let ((signal (condition-signaller type '(filename operator operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(apply-frame/operands frame))))))))))
(set! condition-type:fasload-error
- (make-condition-type 'FASLOAD-ERROR condition-type:file-error
- '(OPERATOR OPERANDS)
+ (make-condition-type 'fasload-error condition-type:file-error
+ '(operator operands)
false))
(set! condition-type:fasl-file-bad-data
- (make-condition-type 'FASL-FILE-BAD-DATA condition-type:fasload-error '()
+ (make-condition-type 'fasl-file-bad-data condition-type:fasload-error '()
(lambda (condition port)
(write-string "Attempt to read binary file " port)
- (write (access-condition condition 'FILENAME) port)
+ (write (access-condition condition 'filename) port)
(write-string " failed: either it's not binary or the wrong version."
port))))
-(define-fasload-error 'FASL-FILE-BAD-DATA
+(define-fasload-error 'fasl-file-bad-data
condition-type:fasl-file-bad-data)
(set! condition-type:fasl-file-compiled-mismatch
- (make-condition-type 'FASL-FILE-COMPILED-MISMATCH
+ (make-condition-type 'fasl-file-compiled-mismatch
condition-type:fasl-file-bad-data
'()
false))
-(define-fasload-error 'FASLOAD-COMPILED-MISMATCH
+(define-fasload-error 'fasload-compiled-mismatch
condition-type:fasl-file-compiled-mismatch)
(set! condition-type:fasl-file-too-big
- (make-condition-type 'FASL-FILE-TOO-BIG condition-type:fasload-error '()
+ (make-condition-type 'fasl-file-too-big condition-type:fasload-error '()
(lambda (condition port)
(write-string "Attempt to read binary file " port)
- (write (access-condition condition 'FILENAME) port)
+ (write (access-condition condition 'filename) port)
(write-string " failed: it's too large to fit in the heap." port))))
-(define-fasload-error 'FASL-FILE-TOO-BIG
+(define-fasload-error 'fasl-file-too-big
condition-type:fasl-file-too-big)
(set! condition-type:wrong-arity-primitives
- (make-condition-type 'WRONG-ARITY-PRIMITIVES condition-type:fasload-error '()
+ (make-condition-type 'wrong-arity-primitives condition-type:fasload-error '()
(lambda (condition port)
(write-string "Attempt to read binary file " port)
- (write (access-condition condition 'FILENAME) port)
+ (write (access-condition condition 'filename) port)
(write-string " failed: it contains primitives with incorrect arity."
port))))
-(define-fasload-error 'WRONG-ARITY-PRIMITIVES
+(define-fasload-error 'wrong-arity-primitives
condition-type:wrong-arity-primitives)
(set! condition-type:fasload-band
- (make-condition-type 'FASLOAD-BAND condition-type:fasl-file-bad-data '()
+ (make-condition-type 'fasload-band condition-type:fasl-file-bad-data '()
false))
-(define-error-handler 'FASLOAD-BAND
+(define-error-handler 'fasload-band
(let ((signal
(condition-signaller condition-type:fasload-band
- '(FILENAME OPERATOR OPERANDS))))
+ '(filename operator operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
;;;; Miscellaneous Errors
(set! condition-type:inapplicable-object
- (make-condition-type 'INAPPLICABLE-OBJECT condition-type:illegal-datum
- '(OPERANDS)
+ (make-condition-type 'inapplicable-object condition-type:illegal-datum
+ '(operands)
(lambda (condition port)
(write-string "The object " port)
- (write (access-condition condition 'DATUM) port)
+ (write (access-condition condition 'datum) port)
(write-string " is not applicable." port))))
-(define-error-handler 'UNDEFINED-PROCEDURE
+(define-error-handler 'undefined-procedure
(let ((signal
(condition-signaller condition-type:inapplicable-object
- '(DATUM OPERANDS))))
+ '(datum operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(lambda ()
(signal continuation operator operands)))))))))
-(define-error-handler 'WRONG-NUMBER-OF-ARGUMENTS
+(define-error-handler 'wrong-number-of-arguments
(let ((signal
(condition-signaller condition-type:wrong-number-of-arguments
- '(DATUM TYPE OPERANDS))))
+ '(datum type operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(let ((arity (procedure-arity operator)))
(signal continuation operator arity operands)))))))))
-(define-error-handler 'FLOATING-OVERFLOW
+(define-error-handler 'floating-overflow
(let ((signal
(condition-signaller condition-type:floating-point-overflow
- '(OPERATOR OPERANDS))))
+ '(operator operands))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
(apply-frame/operands frame)))))))
(set! condition-type:fasdump-environment
- (make-condition-type 'FASDUMP-ENVIRONMENT condition-type:bad-range-argument
+ (make-condition-type 'fasdump-environment condition-type:bad-range-argument
'()
(lambda (condition port)
(write-string
"Object cannot be dumped because it contains an environment: "
port)
- (write (access-condition condition 'DATUM) port))))
+ (write (access-condition condition 'datum) port))))
-(define-error-handler 'FASDUMP-ENVIRONMENT
+(define-error-handler 'fasdump-environment
(let ((signal
(condition-signaller condition-type:fasdump-environment
- '(DATUM OPERATOR OPERAND))))
+ '(datum operator operand))))
(lambda (continuation)
(let ((frame (continuation/first-subproblem continuation)))
(if (apply-frame? frame)
;;;; Asynchronous Microcode Errors
(set! condition-type:hardware-trap
- (make-condition-type 'HARDWARE-TRAP condition-type:error '(NAME CODE)
+ (make-condition-type 'hardware-trap condition-type:error '(name code)
(lambda (condition port)
(write-string "Hardware trap " port)
- (display (access-condition condition 'NAME) port)
- (let ((code (access-condition condition 'CODE)))
+ (display (access-condition condition 'name) port)
+ (let ((code (access-condition condition 'code)))
(if code
(begin
(write-string ": " port)
(write code port)))))))
(set! condition-type:user-microcode-reset
- (make-condition-type 'USER-MICROCODE-RESET condition-type:serious-condition
+ (make-condition-type 'user-microcode-reset condition-type:serious-condition
'()
"User microcode reset"))
(set! hook/hardware-trap
(let ((signal-arithmetic-error
(condition-signaller condition-type:arithmetic-error
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-divide-by-zero
(condition-signaller condition-type:divide-by-zero
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-floating-point-divide-by-zero
(condition-signaller condition-type:floating-point-divide-by-zero
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-floating-point-overflow
(condition-signaller condition-type:floating-point-overflow
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-floating-point-underflow
(condition-signaller condition-type:floating-point-underflow
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-hardware-trap
- (condition-signaller condition-type:hardware-trap '(NAME CODE)))
+ (condition-signaller condition-type:hardware-trap '(name code)))
(signal-inexact-floating-point-result
(condition-signaller condition-type:inexact-floating-point-result
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-integer-divide-by-zero
(condition-signaller condition-type:integer-divide-by-zero
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-invalid-floating-point-operation
(condition-signaller
condition-type:invalid-floating-point-operation
- '(OPERATOR OPERANDS)))
+ '(operator operands)))
(signal-user-microcode-reset
(condition-signaller condition-type:user-microcode-reset '())))
(lambda (name)
(win32-registry/get-value key "Content Type")
(and type
(begin
- (if (not (eq? type 'REG_SZ))
+ (if (not (eq? type 'reg_sz))
(error "Wrong value type in registry entry:"
name))
value))))))
(set! get-environment-variable
(lambda (variable)
(if (not (string? variable))
- (env-error 'GET-ENVIRONMENT-VARIABLE variable))
+ (env-error 'get-environment-variable variable))
(let ((variable (string-upcase variable)))
(cond ((assoc variable environment-variables)
=> cdr)
(set! set-environment-variable!
(lambda (variable value)
(if (not (string? variable))
- (env-error 'SET-ENVIRONMENT-VARIABLE! variable))
+ (env-error 'set-environment-variable! variable))
(let ((variable (string-upcase variable)))
(cond ((assoc variable environment-variables)
=> (lambda (pair) (set-cdr! pair value)))
(set! delete-environment-variable!
(lambda (variable)
(if (not (string? variable))
- (env-error 'DELETE-ENVIRONMENT-VARIABLE! variable))
+ (env-error 'delete-environment-variable! variable))
(set-environment-variable! variable *variable-deleted*)))
(set! reset-environment-variables!
(set! set-environment-variable-default!
(lambda (var val)
(if (not (string? var))
- (env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var))
+ (env-error 'set-environment-variable-default! var))
(let ((var (string-upcase var)))
(cond ((assoc var environment-defaults)
=> (lambda (pair) (set-cdr! pair val)))
(trydir (get-environment-variable "winbootdir")))))
(if (not sysroot)
(error "Unable to find Windows system root."))
- (pathname-new-directory (pathname-as-directory sysroot) '(ABSOLUTE)))))
+ (pathname-new-directory (pathname-as-directory sysroot) '(absolute)))))
\f
(define (file-line-ending pathname)
(if (let ((type (dos/fs-drive-type pathname)))
(or (string=? "NFS" (car type))
(string=? "NtNfs" (car type))
(string=? "Samba" (car type))))
- 'LF
- 'CRLF))
+ 'lf
+ 'crlf))
(define (default-line-ending)
- 'CRLF)
+ 'crlf)
(define (dos/fs-drive-type pathname)
;; (system-name . [nfs-]mount-point)
(fs-type (nt-volume-info/file-system-name volume-info)))
(cond ((or (string-ci=? fs-type "VFAT")
(string-ci=? fs-type "FAT32"))
- 'VFAT) ; ``kind of''
+ 'vfat) ; ``kind of''
((string-ci=? fs-type "FAT")
- #F)
+ #f)
((> (nt-volume-info/max-component-length volume-info) 32)
;; 32 is random -- FAT is 12 and everything else is much larger.
- #T) ; NTFS HPFS
- (else #F)))) ; FAT
+ #t) ; NTFS HPFS
+ (else #f)))) ; FAT
(define (nt-volume-info pathname)
(let ((root
(pathname-new-directory
(directory-pathname (merge-pathnames pathname))
- '(ABSOLUTE))))
+ '(absolute))))
(let ((info
((ucode-primitive nt-get-volume-information 1)
(string-for-primitive (->namestring root)))))
(loop (+ index 1))
filename))))
- (guarantee init-file-specifier? specifier 'INIT-FILE-SPECIFIER->PATHNAME)
+ (guarantee init-file-specifier? specifier 'init-file-specifier->pathname)
(let ((long-base (merge-pathnames ".mit-scheme/" (user-homedir-pathname))))
(if (dos/fs-long-filenames? long-base)
(if (pair? specifier)
(let ((n (string-length (car strings))))
(substring-move! (car strings) 0 n result index)
(let ((index* (fix:+ index n)))
- (string-set! result index* #\NUL)
+ (string-set! result index* #\nul)
(loop (cdr strings) (fix:+ index* 1))))))
result)))
((access get-module-handle env)
(file-namestring
(pathname-default-type
- ((make-primitive-procedure 'SCHEME-PROGRAM-NAME))
+ ((make-primitive-procedure 'scheme-program-name))
"exe"))))
(buf (make-legacy-string 256)))
(substring buf 0 ((access get-module-file-name env) handle buf 256)))))
(define (os/shell-file-name)
(or (get-environment-variable "SHELL")
(get-environment-variable "COMSPEC")
- (if (eq? 'WINNT (nt/windows-type))
+ (if (eq? 'winnt (nt/windows-type))
"cmd.exe"
"command.com")))
(define (nt/windows-type)
(cond ((string-prefix? "Microsoft Windows NT"
microcode-id/operating-system-variant)
- 'WINNT)
+ 'winnt)
((string-prefix? "Microsoft Windows 9"
microcode-id/operating-system-variant)
- 'WIN9X)
+ 'win9x)
((string-prefix? "Microsoft Windows"
microcode-id/operating-system-variant)
- 'WIN3X)
+ 'win3x)
(else #f)))
(define (os/form-shell-command command)
(lambda (self . zs)
self ; ignored
(reduce-comparator = zs 'make-=-operator))
- (lambda () #T)
- (lambda (z) z #T)
+ (lambda () #t)
+ (lambda (z) z #t)
(lambda (z1 z2) (= z1 z2))))
;;(define (make-<-operator <)
(lambda (self . zs)
self ; ignored
(reduce-comparator comparator zs name))
- (lambda () #T)
- (lambda (z) z #T)
+ (lambda () #t)
+ (lambda (z) z #t)
comparator))
(define (make-<-operator <)
(lambda (self x . xs)
self ;ignored
(reduce-max/min max/min x xs 'make-max/min-operator))
- #F
+ #f
(lambda (x) x)
max/min))
(make-arity-dispatched-procedure
(lambda (self z1 #!optional z2) ; required for arity
(error "ATAN operator: should never get to this case" self z1 z2))
- #F
+ #f
atan1
atan2))
self ; ignored
(binary-invert-op z1
(reduce accumulate-op identity zs)))
- #F ; no nullary case
+ #f ; no nullary case
unary-invert-op
binary-invert-op))
(define (finalize-package-record-type!)
(let ((rtd
- (make-record-type "package" '(PARENT CHILDREN NAME ENVIRONMENT))))
+ (make-record-type "package" '(parent children name environment))))
(set! package-tag rtd)
(for-each (lambda (p) (%record-set! p 0 rtd)) *packages*)
(define-unparser-method (record-predicate rtd)
(let ((dir (directory-pathname pathname))
(pkg (package-set-pathname pathname os-type))
(options
- (cons (cons 'OS-TYPE os-type)
+ (cons (cons 'os-type os-type)
(if (default-object? options) '() options))))
(with-working-directory-pathname dir
(lambda ()
(error "Malformed package-description file:" pkg))
(construct-packages-from-file file)
(let ((alternate-loader
- (lookup-option 'ALTERNATE-PACKAGE-LOADER options))
+ (lookup-option 'alternate-package-loader options))
(load-component
(lambda (name environment)
- (load name environment 'DEFAULT #t))))
+ (load name environment 'default #t))))
(if alternate-loader
(alternate-loader load-component options)
(begin
(define (package-file? object)
(and (vector? object)
(fix:= (vector-length object) 4)
- (eq? (package-file/tag object) 'PACKAGE-DESCRIPTIONS)
+ (eq? (package-file/tag object) 'package-descriptions)
(and (index-fixnum? (package-file/version object))
(fix:= (package-file/version object) 2))
(vector-of-type? (package-file/descriptions object)
(vector-of-type? (cdr file-case)
(lambda (clause)
(and (pair? clause)
- (or (eq? (car clause) 'ELSE)
+ (or (eq? (car clause) 'else)
(vector-of-type? (car clause) symbol?))
(vector-of-type? (cdr clause) string?)))))
(vector-of-type? file-case string?))))
(lambda (name)
(or (null? name)
(and (pair? name)
- (eq? (car name) 'PACKAGE)
+ (eq? (car name) 'package)
(null? (cdr name)))))))
(let ((n (vector-length descriptions)))
(do ((i 0 (fix:+ i 1)))
((ucode-primitive vector-cons)
n
(make-unmapped-unassigned-reference-trap))))
- (vector-set! vn 0 'DUMMY-PROCEDURE)
+ (vector-set! vn 0 'dummy-procedure)
(do ((names names (cdr names))
(j 1 (fix:+ j 1)))
((not (pair? names)))
(define null-environment
((ucode-primitive object-set-type)
((ucode-primitive object-type) #f)
- (fix:xor ((ucode-primitive object-datum) #F) 1)))
+ (fix:xor ((ucode-primitive object-datum) #f) 1)))
(define (find-package-environment name)
(package/environment (find-package name)))
((fix:= i n))
(let ((clause (vector-ref clauses i)))
(if (let ((keys (car clause)))
- (or (eq? keys 'ELSE)
+ (or (eq? keys 'else)
(let ((n (vector-length keys)))
(let loop ((i 0))
(and (fix:< i n)
(->pathname (car objects))))))
(define (->pathname object)
- (pathname-arg object #f '->PATHNAME))
+ (pathname-arg object #f '->pathname))
(define (pathname-arg object defaults operator)
(cond ((pathname? object) object)
(else (error:not-a pathname? object operator))))
(define (make-pathname host device directory name type version)
- (let ((host (if host (guarantee-host host 'MAKE-PATHNAME) local-host)))
+ (let ((host (if host (guarantee-host host 'make-pathname) local-host)))
((host-type/operation/make-pathname (host/type host))
host device directory name type version)))
(define (pathname-absolute? pathname)
(let ((directory (pathname-directory pathname)))
(and (pair? directory)
- (eq? (car directory) 'ABSOLUTE))))
+ (eq? (car directory) 'absolute))))
(define (pathname-relative? pathname)
(let ((directory (pathname-directory pathname)))
(and (pair? directory)
- (eq? (car directory) 'RELATIVE))))
+ (eq? (car directory) 'relative))))
(define (pathname-wild? pathname)
(let ((pathname (->pathname pathname)))
(make-uri (if (pathname-absolute? pathname) 'file #f)
#f
(map (lambda (x)
- (cond ((eq? x 'WILD) "*")
- ((eq? x 'UP) "..")
- ((eq? x 'HERE) ".")
+ (cond ((eq? x 'wild) "*")
+ ((eq? x 'up) "..")
+ ((eq? x 'here) ".")
(else x)))
(append (if (pathname-absolute? pathname)
(list "")
#f)))
(define (uri->pathname uri #!optional error?)
- (let ((uri (->uri uri (and error? 'URI->PATHNAME)))
+ (let ((uri (->uri uri (and error? 'uri->pathname)))
(defaults (param:default-pathname-defaults))
(finish
(lambda (device path keyword)
(let ((scheme (uri-scheme uri))
(path
(map (lambda (x)
- (cond ((string=? x "*") 'WILD)
- ((string=? x "..") 'UP)
- ((string=? x ".") 'HERE)
+ (cond ((string=? x "*") 'wild)
+ ((string=? x "..") 'up)
+ ((string=? x ".") 'here)
(else x)))
(uri-path uri)))
(lose
(lambda ()
- (if error? (error:bad-range-argument uri 'URI->PATHNAME))
+ (if error? (error:bad-range-argument uri 'uri->pathname))
#f)))
(case scheme
((file)
(values (car path) (cdr path))
(values device path)))
(if (pair? path)
- (finish device path 'ABSOLUTE)
+ (finish device path 'absolute)
(lose))))
(lose)))
- ((#f) (finish #f path 'RELATIVE))
+ ((#f) (finish #f path 'relative))
(else (lose))))))
(define (missing-component? x)
(or (not x)
- (eq? x 'UNSPECIFIC)))
+ (eq? x 'unspecific)))
\f
;;;; Pathname Syntax
(define (parse-namestring namestring #!optional host defaults)
(let ((host
(if (and (not (default-object? host)) host)
- (guarantee-host host 'PARSE-NAMESTRING)
+ (guarantee-host host 'parse-namestring)
(pathname-host
(if (and (not (default-object? defaults)) defaults)
defaults
namestring host))
((pathname? namestring)
(if (not (host=? host (pathname-host namestring)))
- (error:bad-range-argument namestring 'PARSE-NAMESTRING))
+ (error:bad-range-argument namestring 'parse-namestring))
namestring)
(else
(error:wrong-type-argument namestring "namestring"
- 'PARSE-NAMESTRING)))))
+ 'parse-namestring)))))
(define (->namestring pathname)
(let ((pathname (->pathname pathname)))
(if (and (not (default-object? defaults)) defaults)
(->pathname defaults)
(param:default-pathname-defaults)))
- (pathname (pathname-arg pathname defaults 'MERGE-PATHNAMES)))
+ (pathname (pathname-arg pathname defaults 'merge-pathnames)))
(make-pathname
(or (%pathname-host pathname) (%pathname-host defaults))
(or (%pathname-device pathname)
(cond ((not directory)
default)
((and (pair? directory)
- (eq? (car directory) 'RELATIVE)
+ (eq? (car directory) 'relative)
(pair? default))
(append default (cdr directory)))
(else
(or (%pathname-version pathname)
(and (not (%pathname-name pathname)) (%pathname-version defaults))
(if (default-object? default-version)
- 'NEWEST
+ 'newest
default-version)))))
\f
(define (enough-pathname pathname #!optional defaults)
(if (and (not (default-object? defaults)) defaults)
(->pathname defaults)
(param:default-pathname-defaults)))
- (pathname (pathname-arg pathname defaults 'ENOUGH-PATHNAME)))
+ (pathname (pathname-arg pathname defaults 'enough-pathname)))
(let ((usual
(lambda (component default)
(and (or (symbol? component)
;; and default does not, or vice versa. This is a
;; kludge to make network devices work properly in
;; DOS-like pathnames.
- (and (eq? (car directory) 'ABSOLUTE)
+ (and (eq? (car directory) 'absolute)
(not (boolean=? (and (pair? (cdr directory))
(equal? (cadr directory) ""))
(and (pair? (cdr default))
(let loop
((components (cdr directory)) (components* (cdr default)))
(cond ((null? components*)
- (cons 'RELATIVE components))
+ (cons 'relative components))
((and (not (null? components))
(equal? (car components) (car components*)))
(loop (cdr components) (cdr components*)))
(define (user-homedir-pathname #!optional host)
(let ((host
(if (and (not (default-object? host)) host)
- (guarantee-host host 'USER-HOMEDIR-PATHNAME)
+ (guarantee-host host 'user-homedir-pathname)
local-host)))
((host-type/operation/user-homedir-pathname (host/type host)) host)))
(define (init-file-pathname #!optional host)
(let ((host
(if (and (not (default-object? host)) host)
- (guarantee-host host 'INIT-FILE-PATHNAME)
+ (guarantee-host host 'init-file-pathname)
local-host)))
((host-type/operation/init-file-pathname (host/type host)) host)))
(define library-directory-path)
\f
(define known-host-types
- '((0 UNIX)
- (1 DOS NT)))
+ '((0 unix)
+ (1 dos nt)))
(define (host-name->index name)
(let loop ((entries known-host-types))
unspecific)))))
(define (make-unimplemented-host-type index)
- (let ((name (or (host-index->name index) 'UNKNOWN)))
+ (let ((name (or (host-index->name index) 'unknown)))
(let ((fail
(lambda arguments
(error "Unimplemented host type:" name arguments))))
(add-event-receiver! event:after-restore reset-package!))
(define (initialize-parser-method!)
- (define-bracketed-object-parser-method 'PATHNAME pathname-parser-method))
\ No newline at end of file
+ (define-bracketed-object-parser-method 'pathname pathname-parser-method))
\ No newline at end of file
(false? (channel-type channel)))
(define-integrable (channel-type=file? channel)
- (eq? 'FILE (channel-type channel)))
+ (eq? 'file (channel-type channel)))
(define-integrable (channel-type=directory? channel)
- (eq? 'DIRECTORY (channel-type channel)))
+ (eq? 'directory (channel-type channel)))
(define (channel-type=terminal? channel)
(let ((type (channel-type channel)))
- (or (eq? 'TERMINAL type)
- (eq? 'UNIX-PTY-MASTER type))))
+ (or (eq? 'terminal type)
+ (eq? 'unix-pty-master type))))
(define (channel-close channel)
(with-gc-finalizer-lock open-channels
end))))
(declare (integrate-operator do-read))
(if (and have-select? (not (channel-type=file? channel)))
- (let ((result (test-for-io-on-channel channel 'READ
+ (let ((result (test-for-io-on-channel channel 'read
(channel-blocking? channel))))
(case result
- ((READ HANGUP ERROR) (do-read))
- ((#F) #f)
- ((PROCESS-STATUS-CHANGE INTERRUPT) #t)
+ ((read hangup error) (do-read))
+ ((#f) #f)
+ ((process-status-change interrupt) #t)
(else (error "Unexpected test-for-io-on-channel value:" result))))
(do-read))))
end))))
(declare (integrate-operator do-write))
(if (and have-select? (not (channel-type=file? channel)))
- (let ((result (test-for-io-on-channel channel 'WRITE
+ (let ((result (test-for-io-on-channel channel 'write
(channel-blocking? channel))))
(case result
- ((WRITE HANGUP ERROR) (do-write))
- ((#F) 0)
- ((PROCESS-STATUS-CHANGE INTERRUPT) #t)
+ ((write hangup error) (do-write))
+ ((#f) 0)
+ ((process-status-change interrupt) #t)
(else (error "Unexpected test-for-io-on-channel value:" result))))
(do-write))))
\f
(define (channel-has-input? channel)
(let loop ()
(let ((mode (test-select-descriptor (channel-descriptor-for-select channel)
- 'READ)))
+ 'read)))
(if (pair? mode)
- (or (eq? (car mode) 'READ)
- (eq? (car mode) 'READ/WRITE))
+ (or (eq? (car mode) 'read)
+ (eq? (car mode) 'read/write))
(loop)))))
(define-integrable (channel-descriptor-for-select channel)
#f
(encode-select-registry-mode mode))))
(cond ((>= result 0) (decode-select-registry-mode result))
- ((= result -1) 'INTERRUPT)
+ ((= result -1) 'interrupt)
((= result -2)
(handle-subprocess-status-change)
- 'PROCESS-STATUS-CHANGE)
+ 'process-status-change)
(else
(error "Illegal result from TEST-SELECT-DESCRIPTOR:" result)))))
((READ) 1)
((WRITE) 2)
((READ/WRITE) 3)
- (else (error:bad-range-argument mode 'ENCODE-SELECT-REGISTRY-MODE))))
+ (else (error:bad-range-argument mode 'encode-select-registry-mode))))
(define (decode-select-registry-mode mode)
(cons (if (select-registry-mode-read? mode)
- (if (select-registry-mode-write? mode) 'READ/WRITE 'READ)
- (if (select-registry-mode-write? mode) 'WRITE #f))
+ (if (select-registry-mode-write? mode) 'read/write 'read)
+ (if (select-registry-mode-write? mode) 'write #f))
(let ((tail
(if (select-registry-mode-hangup? mode)
- (list 'HANGUP)
+ (list 'hangup)
'())))
(if (select-registry-mode-error? mode)
- (cons 'ERROR tail)
+ (cons 'error tail)
tail))))
(define (simplify-select-registry-mode mode)
- (cond ((memq 'HANGUP (cdr mode)) 'HANGUP)
- ((memq 'ERROR (cdr mode)) 'ERROR)
+ (cond ((memq 'hangup (cdr mode)) 'hangup)
+ ((memq 'error (cdr mode)) 'error)
(else (car mode))))
(define-integrable (select-registry-mode-read? mode)
(begin
(deallocate-select-registry-result-vectors vfd vmode)
(cond ((= 0 result) #f)
- ((= -1 result) 'INTERRUPT)
- ((= -2 result) 'PROCESS-STATUS-CHANGE)
+ ((= -1 result) 'interrupt)
+ ((= -2 result) 'process-status-change)
(else
(error "Illegal result from TEST-SELECT-REGISTRY:"
result))))))))
(define-guarantee dld-handle "dynamic-loader handle")
(define (dld-handle-valid? handle)
- (guarantee-dld-handle handle 'DLD-HANDLE-VALID?)
+ (guarantee-dld-handle handle 'dld-handle-valid?)
(if (dld-handle-address handle) #t #f))
(define (guarantee-valid-dld-handle object #!optional caller)
unspecific)
(define (dld-unload-file handle)
- (guarantee-dld-handle handle 'DLD-UNLOAD-FILE)
+ (guarantee-dld-handle handle 'dld-unload-file)
(with-thread-mutex-lock dld-handles-mutex
(lambda ()
(%dld-unload-file handle)
(set-dld-handle-address! handle #f)))))
(define (dld-lookup-symbol handle name)
- (guarantee-dld-handle handle 'DLD-LOOKUP-SYMBOL)
- (guarantee string? name 'DLD-LOOKUP-SYMBOL)
+ (guarantee-dld-handle handle 'dld-lookup-symbol)
+ (guarantee string? name 'dld-lookup-symbol)
((ucode-primitive dld-lookup-symbol 2)
(dld-handle-address handle)
(string-for-primitive name)))
(sc-macro-transformer
(lambda (form env)
(if (syntax-match? '(form) (cdr form))
- (compile-top-level (cadr form) 'OBJECT env)
+ (compile-top-level (cadr form) 'object env)
(ill-formed-syntax form)))))
(define (apply-object-parser parser object)
(sc-macro-transformer
(lambda (form env)
(if (syntax-match? '(* form) (cdr form))
- (compile-top-level `(SEQ ,@(cdr form)) 'LIST env)
+ (compile-top-level `(seq ,@(cdr form)) 'list env)
(ill-formed-syntax form)))))
(define (apply-list-parser parser items)
(sc-macro-transformer
(lambda (form env)
(if (syntax-match? '(* form) (cdr form))
- (compile-top-level `(SEQ ,@(cdr form)) 'VECTOR env)
+ (compile-top-level `(seq ,@(cdr form)) 'vector env)
(ill-formed-syntax form)))))
(define (apply-vector-parser parser vector #!optional start end)
(call-generic))
((eq? callee-context caller-context)
(call-specific))
- ((eq? callee-context 'OBJECT)
- ((get-context-method 'CALL-OBJECT-METHOD caller-context)
+ ((eq? callee-context 'object)
+ ((get-context-method 'call-object-method caller-context)
(call-specific)))
(else
(call-generic)))))))
(define (rewrite-pattern pattern)
(cond ((identifier? pattern)
- (rewrite-pattern `(SEXP ,pattern)))
+ (rewrite-pattern `(sexp ,pattern)))
((or (char? pattern)
(string? pattern)
(number? pattern)
(boolean? pattern)
(null? pattern))
- (rewrite-pattern `(QUOTE ,pattern)))
+ (rewrite-pattern `(quote ,pattern)))
((syntax-match? '('+ * form) pattern)
- (rewrite-pattern `(SEQ ,@(cdr pattern) (* ,@(cdr pattern)))))
+ (rewrite-pattern `(seq ,@(cdr pattern) (* ,@(cdr pattern)))))
((syntax-match? '('? * form) pattern)
- (rewrite-pattern `(ALT (SEQ ,@(cdr pattern)) (VALUES))))
+ (rewrite-pattern `(alt (seq ,@(cdr pattern)) (values))))
(else pattern)))
\f
(define (get-pattern-compiler name caller-context)
(let ((callee-context (pc-context pc)))
(or (list? callee-context)
(eq? callee-context caller-context)
- (eq? callee-context 'OBJECT)
- (eq? callee-context 'ANY)))))
+ (eq? callee-context 'object)
+ (eq? callee-context 'any)))))
pattern-compilers))
(define (define-pattern-compiler template context compiler)
\f
;;;; Object context
-(define-pattern-compiler '(MATCH-ANY) 'OBJECT
+(define-pattern-compiler '(match-any) 'object
(lambda (pattern env)
pattern env
(make-object-parser
(lambda (item win lose)
`(,win ,(single-val item) ,lose)))))
-(define-pattern-compiler '(MATCH-IF EXPRESSION) 'OBJECT
+(define-pattern-compiler '(match-if expression) 'object
(lambda (pattern env)
(make-object-parser
(lambda (item win lose)
- `(IF (,(close-syntax (cadr pattern) env) ,item)
+ `(if (,(close-syntax (cadr pattern) env) ,item)
(,win ,(single-val item) ,lose)
(,lose))))))
-(define-pattern-compiler '(NOISE-IF EXPRESSION) 'OBJECT
+(define-pattern-compiler '(noise-if expression) 'object
(lambda (pattern env)
(make-object-parser
(lambda (item win lose)
- `(IF (,(close-syntax (cadr pattern) env) ,item)
+ `(if (,(close-syntax (cadr pattern) env) ,item)
(,win ,(null-vals) ,lose)
(,lose))))))
-(define-pattern-compiler '(MATCH DATUM) 'OBJECT
+(define-pattern-compiler '(match datum) 'object
(lambda (pattern env)
env
(make-object-parser
(lambda (item win lose)
- `(IF (,(equality-predicate (cadr pattern)) ,item ',(cadr pattern))
+ `(if (,(equality-predicate (cadr pattern)) ,item ',(cadr pattern))
(,win ,(single-val item) ,lose)
(,lose))))))
-(define-pattern-compiler '(QUOTE DATUM) 'OBJECT
+(define-pattern-compiler '(quote datum) 'object
(lambda (pattern env)
env
(make-object-parser
(lambda (item win lose)
- `(IF (,(equality-predicate (cadr pattern)) ,item ',(cadr pattern))
+ `(if (,(equality-predicate (cadr pattern)) ,item ',(cadr pattern))
(,win ,(null-vals) ,lose)
(,lose))))))
(char? datum)
(boolean? datum)
(null? datum))
- 'EQ?)
- ((number? datum) 'EQV?)
- (else 'EQUAL?)))
+ 'eq?)
+ ((number? datum) 'eqv?)
+ (else 'equal?)))
-(define-context-method 'VALUES 'OBJECT
+(define-context-method 'values 'object
(lambda (vals)
(make-object-parser
(lambda (item win lose)
item
`(,win ,vals ,lose)))))
-(define-context-method 'ALT 'OBJECT
+(define-context-method 'alt 'object
(lambda (make-body)
(make-object-parser
(lambda (item win lose)
`(,callee ,item ,win ,lose))
lose)))))
\f
-(define-context-method 'TRANSFORM-VALS 'OBJECT
+(define-context-method 'transform-vals 'object
(lambda (callee transform)
(make-object-parser
(lambda (item win lose)
`(,win ,vals ,lose)))))
,lose)))))
-(define-pattern-compiler '(CONS FORM FORM) 'OBJECT
+(define-pattern-compiler '(cons form form) 'object
(lambda (pattern env)
(make-object-parser
(lambda (item win lose)
- `(IF (PAIR? ,item)
- (,(compile-pattern (cadr pattern) 'OBJECT env)
- (CAR ,item)
+ `(if (pair? ,item)
+ (,(compile-pattern (cadr pattern) 'object env)
+ (car ,item)
,(make-object-winner
(lambda (vals lose)
- `(,(compile-pattern (caddr pattern) 'OBJECT env)
- (CDR ,item)
+ `(,(compile-pattern (caddr pattern) 'object env)
+ (cdr ,item)
,(make-object-winner
(lambda (vals* lose)
`(,win ,(join-vals vals vals*)
,lose)
(,lose))))))
-(define-pattern-compiler '(LIST * FORM) 'OBJECT
+(define-pattern-compiler '(list * form) 'object
(lambda (pattern env)
(make-object-parser
(lambda (item win lose)
- `(,(compile-pattern `(SEQ ,@(cdr pattern) (END)) 'LIST env)
+ `(,(compile-pattern `(seq ,@(cdr pattern) (end)) 'list env)
,item
,(make-list-winner
(lambda (items vals lose)
`(,win ,vals ,lose)))
,lose)))))
-(define-pattern-compiler '(VECTOR * FORM) 'OBJECT
+(define-pattern-compiler '(vector * form) 'object
(lambda (pattern env)
(make-object-parser
(lambda (item win lose)
- `(IF (VECTOR? ,item)
- (,(compile-pattern `(SEQ ,@(cdr pattern) (END)) 'VECTOR env)
+ `(if (vector? ,item)
+ (,(compile-pattern `(seq ,@(cdr pattern) (end)) 'vector env)
,item
0
- (VECTOR-LENGTH ,item)
+ (vector-length ,item)
,(make-vector-winner
(lambda (start vals lose)
start
\f
;;;; Generic patterns
-(define-pattern-compiler '(SEXP EXPRESSION) 'ANY
+(define-pattern-compiler '(sexp expression) 'any
(lambda (pattern context env)
context
(close-syntax (cadr pattern) env)))
-(define-pattern-compiler '(VALUES * EXPRESSION) 'ANY
+(define-pattern-compiler '(values * expression) 'any
(lambda (pattern context env)
- ((get-context-method 'VALUES context)
+ ((get-context-method 'values context)
(apply join-vals
(map (lambda (expr)
(single-val (close-syntax expr env)))
(cdr pattern))))))
-(define-pattern-compiler '(ALT * FORM) 'ANY
+(define-pattern-compiler '(alt * form) 'any
(lambda (pattern context env)
- ((get-context-method 'ALT context)
+ ((get-context-method 'alt context)
(lambda (make-call lose)
(let loop ((patterns (cdr pattern)))
(if (pair? patterns)
(make-loser (loop (cdr patterns))))
`(,lose)))))))
-(define-pattern-compiler '(* * FORM) '(LIST VECTOR)
+(define-pattern-compiler '(* * form) '(list vector)
(lambda (pattern context env)
((get-context-method '* context)
(lambda (location lose make-call make-termination)
- (make-loop `((LOCATION ,location)
- (VALS ,(null-vals))
- (LOSE ,lose))
+ (make-loop `((location ,location)
+ (vals ,(null-vals))
+ (lose ,lose))
(lambda (loop location vals lose)
- (make-call (compile-pattern `(SEQ ,@(cdr pattern)) context env)
+ (make-call (compile-pattern `(seq ,@(cdr pattern)) context env)
location
(lambda (location vals* lose)
`(,loop ,location
,lose))
(make-loser (make-termination location vals lose)))))))))
-(define-pattern-compiler '(SEQ * FORM) '(LIST VECTOR)
+(define-pattern-compiler '(seq * form) '(list vector)
(lambda (pattern context env)
(let ((callees
(map (lambda (pattern)
(if (and (pair? callees)
(null? (cdr callees)))
(car callees)
- ((get-context-method 'SEQ context)
+ ((get-context-method 'seq context)
(lambda (location lose make-recursion make-termination)
(if (pair? callees)
(let loop
(make-termination location vals lose)))
(make-termination location (null-vals) lose))))))))
\f
-(define-pattern-compiler '(NOISE FORM) 'ANY
+(define-pattern-compiler '(noise form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (cadr pattern) context env)
(lambda (vals lose make-win)
vals
(make-win (null-vals) lose)))))
-(define-pattern-compiler '(MAP EXPRESSION FORM) 'ANY
+(define-pattern-compiler '(map expression form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (caddr pattern) context env)
(lambda (vals lose make-win)
- (make-win `(MAP-STRUCTURE-PARSER-VALUES
+ (make-win `(map-structure-parser-values
,(close-syntax (cadr pattern) env)
,vals)
lose)))))
-(define-pattern-compiler '(ENCAPSULATE EXPRESSION FORM) 'ANY
+(define-pattern-compiler '(encapsulate expression form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (caddr pattern) context env)
(lambda (vals lose make-win)
(make-win (single-val
vals))
lose)))))
-(define-pattern-compiler '(QUALIFY EXPRESSION FORM) 'ANY
+(define-pattern-compiler '(qualify expression form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (caddr pattern) context env)
(lambda (vals lose make-win)
- `(IF ,(call-out (close-syntax (cadr pattern) env)
+ `(if ,(call-out (close-syntax (cadr pattern) env)
vals)
,(make-win vals lose)
(,lose))))))
-(define-pattern-compiler '(DISQUALIFY EXPRESSION FORM) 'ANY
+(define-pattern-compiler '(disqualify expression form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (caddr pattern) context env)
(lambda (vals lose make-win)
- `(IF (NOT ,(call-out (close-syntax (cadr pattern) env)
+ `(if (not ,(call-out (close-syntax (cadr pattern) env)
vals))
,(make-win vals lose)
(,lose))))))
-(define-pattern-compiler '(TRANSFORM EXPRESSION FORM) 'ANY
+(define-pattern-compiler '(transform expression form) 'any
(lambda (pattern context env)
- ((get-context-method 'TRANSFORM-VALS context)
+ ((get-context-method 'transform-vals context)
(compile-pattern (caddr pattern) context env)
(lambda (vals lose make-win)
- (make-let `((VALS
+ (make-let `((vals
,(call-out (close-syntax (cadr pattern) env)
vals)))
(lambda (vals)
- `(IF ,vals
- ,(make-win `(LIST->STRUCTURE-PARSER-VALUES ,vals)
+ `(if ,vals
+ ,(make-win `(list->structure-parser-values ,vals)
lose)
(,lose))))))))
-(define-pattern-compiler '(OBJECT FORM) '(LIST VECTOR)
+(define-pattern-compiler '(object form) '(list vector)
(lambda (pattern context env)
- ((get-context-method 'CALL-OBJECT-METHOD context)
- (compile-pattern (cadr pattern) 'OBJECT env))))
+ ((get-context-method 'call-object-method context)
+ (compile-pattern (cadr pattern) 'object env))))
\f
;;;; List context
-(define-pattern-compiler '(END) 'LIST
+(define-pattern-compiler '(end) 'list
(lambda (pattern env)
pattern env
(make-list-parser
(lambda (items win lose)
- `(IF (NULL? ,items)
+ `(if (null? ,items)
(,win ,items ,(null-vals) ,lose)
(,lose))))))
-(define-context-method 'CALL-OBJECT-METHOD 'LIST
+(define-context-method 'call-object-method 'list
(lambda (callee)
(make-list-parser
(lambda (items win lose)
- `(IF (PAIR? ,items)
- (,callee (CAR ,items)
+ `(if (pair? ,items)
+ (,callee (car ,items)
,(make-object-winner
(lambda (vals lose)
- `(,win (CDR ,items) ,vals ,lose)))
+ `(,win (cdr ,items) ,vals ,lose)))
,lose)
(,lose))))))
-(define-context-method 'SEQ 'LIST
+(define-context-method 'seq 'list
(lambda (make-body)
(make-list-parser
(lambda (items win lose)
(lambda (items vals lose)
`(,win ,items ,vals ,lose)))))))
-(define-context-method 'VALUES 'LIST
+(define-context-method 'values 'list
(lambda (vals)
(make-list-parser
(lambda (items win lose)
`(,win ,items ,vals ,lose)))))
-(define-context-method 'ALT 'LIST
+(define-context-method 'alt 'list
(lambda (make-body)
(make-list-parser
(lambda (items win lose)
`(,callee ,items ,win ,lose))
lose)))))
-(define-context-method '* 'LIST
+(define-context-method '* 'list
(lambda (make-body)
(make-list-parser
(lambda (items win lose)
(lambda (items vals lose)
`(,win ,items ,vals ,lose)))))))
-(define-context-method 'TRANSFORM-VALS 'LIST
+(define-context-method 'transform-vals 'list
(lambda (callee transform)
(make-list-parser
(lambda (items win lose)
\f
;;;; Vector context
-(define-pattern-compiler '(END) 'VECTOR
+(define-pattern-compiler '(end) 'vector
(lambda (pattern env)
pattern env
(make-vector-parser
(lambda (vector start end win lose)
vector
- `(IF (FIX:= ,start ,end)
+ `(if (fix:= ,start ,end)
(,win ,end ,(null-vals) ,lose)
(,lose))))))
-(define-context-method 'CALL-OBJECT-METHOD 'VECTOR
+(define-context-method 'call-object-method 'vector
(lambda (callee)
(make-vector-parser
(lambda (vector start end win lose)
- `(IF (FIX:< ,start ,end)
- (,callee (VECTOR-REF ,vector ,start)
+ `(if (fix:< ,start ,end)
+ (,callee (vector-ref ,vector ,start)
,(make-object-winner
(lambda (vals lose)
- `(,win (FIX:+ ,start 1) ,vals ,lose)))
+ `(,win (fix:+ ,start 1) ,vals ,lose)))
,lose)
(,lose))))))
-(define-context-method 'SEQ 'VECTOR
+(define-context-method 'seq 'vector
(lambda (make-body)
(make-vector-parser
(lambda (vector start end win lose)
(lambda (start vals lose)
`(,win ,start ,vals ,lose)))))))
-(define-context-method 'VALUES 'VECTOR
+(define-context-method 'values 'vector
(lambda (vals)
(make-vector-parser
(lambda (vector start end win lose)
vector end
`(,win ,start ,vals ,lose)))))
-(define-context-method 'ALT 'VECTOR
+(define-context-method 'alt 'vector
(lambda (make-body)
(make-vector-parser
(lambda (vector start end win lose)
`(,callee ,vector ,start ,end ,win ,lose))
lose)))))
-(define-context-method '* 'VECTOR
+(define-context-method '* 'vector
(lambda (make-body)
(make-vector-parser
(lambda (vector start end win lose)
(lambda (start vals lose)
`(,win ,start ,vals ,lose)))))))
-(define-context-method 'TRANSFORM-VALS 'VECTOR
+(define-context-method 'transform-vals 'vector
(lambda (callee transform)
(make-vector-parser
(lambda (vector start end win lose)
(define (join-vals . valss)
(reduce-right (lambda (vals1 vals2)
- `(CONS ,vals1 ,vals2))
+ `(cons ,vals1 ,vals2))
(null-vals)
valss))
(define (single-val val)
- `(CONS ',single-val-marker ,val))
+ `(cons ',single-val-marker ,val))
(define (null-vals)
''())
(else
(error:not-a structure-parser-values?
vals
- 'STRUCTURE-PARSER-VALUES->LIST)))))
+ 'structure-parser-values->list)))))
(define (list->structure-parser-values items)
(map (lambda (item)
(loop (cdr vals*)))))
(else
(error:not-a structure-parser-values? vals
- 'MAP-STRUCTURE-PARSER-VALUES)))))
+ 'map-structure-parser-values)))))
\f
(define (structure-parser-values? object)
(let loop ((object object))
(else
(error:not-a structure-parser-values?
vals
- 'STRUCTURE-PARSER-VALUES-LENGTH)))))
+ 'structure-parser-values-length)))))
(define (structure-parser-values-ref vals index)
- (let ((caller 'STRUCTURE-PARSER-VALUES-REF))
+ (let ((caller 'structure-parser-values-ref))
(define (loop vals* i stack)
(cond ((null? vals*)
;;;; Helpers for code generation
(define (make-object-parser make-body)
- (make-lambda '(ITEM WIN LOSE) make-body))
+ (make-lambda '(item win lose) make-body))
(define (make-object-winner make-body)
- (make-lambda '(VALS LOSE) make-body))
+ (make-lambda '(vals lose) make-body))
(define (make-list-parser make-body)
- (make-lambda '(ITEMS WIN LOSE) make-body))
+ (make-lambda '(items win lose) make-body))
(define (make-list-winner make-body)
- (make-lambda '(ITEMS VALS LOSE) make-body))
+ (make-lambda '(items vals lose) make-body))
(define (make-vector-parser make-body)
- (make-lambda '(VECTOR START END WIN LOSE) make-body))
+ (make-lambda '(vector start end win lose) make-body))
(define (make-vector-winner make-body)
- (make-lambda '(START VALS LOSE) make-body))
+ (make-lambda '(start vals lose) make-body))
(define (make-loser body)
(make-lambda '() (lambda () body)))
(define (call-out procedure vals)
- `(APPLY ,procedure (STRUCTURE-PARSER-VALUES->LIST ,vals)))
+ `(apply ,procedure (structure-parser-values->list ,vals)))
(define (make-lambda names make-body)
(call-with-new-names names
(lambda names
- `(LAMBDA ,names
+ `(lambda ,names
,(apply make-body names)))))
(define (make-let bindings make-body)
(args (map cadr bindings)))
(call-with-new-names names
(lambda names
- `((LAMBDA ,names
+ `((lambda ,names
,(apply make-body names))
,@args)))))
(define (make-loop bindings make-body)
(let ((names (map car bindings))
(inits (map cadr bindings)))
- (call-with-new-names (cons 'LOOP names)
+ (call-with-new-names (cons 'loop names)
(lambda names
- `(LET ,(car names)
+ `(let ,(car names)
,(map (lambda (name init)
`(,name ,init))
(cdr names)
(substitute (map cdr to-substitute) body)
body))))
(if (pair? to-keep)
- `((LAMBDA ,(map cadr to-keep) ,new-body)
+ `((lambda ,(map cadr to-keep) ,new-body)
,@(map cddr to-keep))
new-body))))))
\f
(lambda (expr loop)
(let ((names (cadr expr))
(body (loop (caddr expr))))
- `(LAMBDA ,names
+ `(lambda ,names
,@(filter (lambda (name)
(= (count-refs-in name body) 0))
names)
(define peephole-optimizers '())
-(define-peephole-optimizer `('CONS EXPRESSION EXPRESSION)
+(define-peephole-optimizer `('cons expression expression)
(lambda (expr win lose)
(cond ((equal? (cadr expr) (null-vals)) (win (caddr expr)))
((equal? (caddr expr) (null-vals)) (win (cadr expr)))
(else (lose)))))
-(define-peephole-optimizer `('FIX:+ ,fix:fixnum? ,fix:fixnum?)
+(define-peephole-optimizer `('fix:+ ,fix:fixnum? ,fix:fixnum?)
(lambda (expr win lose)
lose
(win (fix:+ (cadr expr) (caddr expr)))))
-(define-peephole-optimizer `('FIX:+ ('FIX:+ EXPRESSION ,fix:fixnum?)
+(define-peephole-optimizer `('fix:+ ('fix:+ expression ,fix:fixnum?)
,fix:fixnum?)
(lambda (expr win lose)
lose
- (win `(FIX:+ ,(cadr (cadr expr))
+ (win `(fix:+ ,(cadr (cadr expr))
,(fix:+ (caddr (cadr expr)) (caddr expr))))))
-(define-peephole-optimizer `('FIX:< ,fix:fixnum? ,fix:fixnum?)
+(define-peephole-optimizer `('fix:< ,fix:fixnum? ,fix:fixnum?)
(lambda (expr win lose)
lose
(win (fix:< (cadr expr) (caddr expr)))))
-(define-peephole-optimizer `('FIX:< ('FIX:+ EXPRESSION ,fix:fixnum?)
+(define-peephole-optimizer `('fix:< ('fix:+ expression ,fix:fixnum?)
,fix:fixnum?)
(lambda (expr win lose)
lose
(a (caddr (cadr expr)))
(b (caddr expr)))
(if (fix:<= a b)
- (win `(FIX:< ,base ,(fix:- b a)))
+ (win `(fix:< ,base ,(fix:- b a)))
;; We know that BASE is >= 0.
- (win '#F)))))
+ (win '#f)))))
\f
-(define-peephole-optimizer '('IF #F EXPRESSION EXPRESSION)
+(define-peephole-optimizer '('if #f expression expression)
(lambda (expr win lose)
lose
(win (cadddr expr))))
-(define-peephole-optimizer '('IF #T EXPRESSION EXPRESSION)
+(define-peephole-optimizer '('if #t expression expression)
(lambda (expr win lose)
lose
(win (caddr expr))))
-(define-peephole-optimizer '('IF EXPRESSION
- ('IF EXPRESSION EXPRESSION EXPRESSION)
- EXPRESSION)
+(define-peephole-optimizer '('if expression
+ ('if expression expression expression)
+ expression)
(lambda (expr win lose)
(if (equal? (cadddr (caddr expr))
(cadddr expr))
- (win `(IF (AND ,(cadr expr)
+ (win `(if (and ,(cadr expr)
,(cadr (caddr expr)))
,(caddr (caddr expr))
,(cadddr expr)))
(lose))))
-(define-peephole-optimizer '('AND * EXPRESSION)
+(define-peephole-optimizer '('and * expression)
(lambda (expr win lose)
(cond ((null? (cdr expr))
- (win '#T))
+ (win '#t))
((null? (cddr expr))
(win (cadr expr)))
- ((memq '#T (cdr expr))
- (win (delq '#T (cdr expr))))
- ((memq '#F (cdr expr))
- (win '#F))
+ ((memq '#t (cdr expr))
+ (win (delq '#t (cdr expr))))
+ ((memq '#f (cdr expr))
+ (win '#f))
((any (lambda (expr)
(syntax-match? '('and * expression) expr))
(cdr expr))
- (win `(AND
+ (win `(and
,@(append-map (lambda (expr)
(if (syntax-match? '('and * expression) expr)
(cdr expr)
expr)
(define (rewrite-lambda expr loop)
- `(LAMBDA ,(cadr expr)
+ `(lambda ,(cadr expr)
,(loop (caddr expr))))
(define (rewrite-loop expr loop)
- `(LET ,(cadr expr)
+ `(let ,(cadr expr)
,(map (lambda (binding)
(list (car binding)
(loop (cadr binding))))
(or (memq (car keywords) (cdr keywords))
(loop (cdr keywords)))))
(syntax-error "Keywords list contains duplicates:" keywords)
- (let ((r-form (rename 'FORM))
- (r-rename (rename 'RENAME))
- (r-compare (rename 'COMPARE)))
- `(,(rename 'ER-MACRO-TRANSFORMER)
- (,(rename 'LAMBDA)
+ (let ((r-form (rename 'form))
+ (r-rename (rename 'rename))
+ (r-compare (rename 'compare)))
+ `(,(rename 'er-macro-transformer)
+ (,(rename 'lambda)
(,r-form ,r-rename ,r-compare)
- (,(rename 'DECLARE) (IGNORABLE ,r-rename ,r-compare))
+ (,(rename 'declare) (ignorable ,r-rename ,r-compare))
,(let loop ((clauses clauses))
(if (pair? clauses)
(let ((pattern (caar clauses)))
(let ((sids
(parse-pattern rename compare keywords
pattern r-form)))
- `(,(rename 'IF)
+ `(,(rename 'if)
,(generate-match rename compare keywords
r-rename r-compare
pattern r-form)
,(generate-output rename compare r-rename
sids (cadar clauses))
,(loop (cdr clauses)))))
- `(,(rename 'BEGIN)
- (,(rename 'ILL-FORMED-SYNTAX) ,r-form))))))))))))
+ `(,(rename 'begin)
+ (,(rename 'ill-formed-syntax) ,r-form))))))))))))
(define (parse-pattern rename compare keywords pattern expression)
(let loop
((and (or (zero-or-more? pattern rename compare)
(at-least-one? pattern rename compare))
(null? (cddr pattern)))
- (let ((variable ((make-local-identifier-renamer) 'CONTROL)))
+ (let ((variable ((make-local-identifier-renamer) 'control)))
(loop (car pattern)
variable
sids
(make-sid variable expression control))))
((pair? pattern)
(loop (car pattern)
- `(,(rename 'CAR) ,expression)
+ `(,(rename 'car) ,expression)
(loop (cdr pattern)
- `(,(rename 'CDR) ,expression)
+ `(,(rename 'cdr) ,expression)
sids
control)
control))
(lambda (pattern expression)
(cond ((identifier? pattern)
(if (memq pattern keywords)
- (let ((temp (rename 'TEMP)))
- `((,(rename 'LAMBDA)
+ (let ((temp (rename 'temp)))
+ `((,(rename 'lambda)
(,temp)
- (,(rename 'IF)
- (,(rename 'IDENTIFIER?) ,temp)
+ (,(rename 'if)
+ (,(rename 'identifier?) ,temp)
(,r-compare ,temp
(,r-rename ,(syntax-quote pattern)))
#f))
(do-list (car pattern) expression))
((and (at-least-one? pattern rename compare)
(null? (cddr pattern)))
- `(,(rename 'IF) (,(rename 'NULL?) ,expression)
- #F
+ `(,(rename 'if) (,(rename 'null?) ,expression)
+ #f
,(do-list (car pattern) expression)))
((pair? pattern)
(let ((generate-pair
(lambda (expression)
(conjunction
- `(,(rename 'PAIR?) ,expression)
+ `(,(rename 'pair?) ,expression)
(conjunction
(loop (car pattern)
- `(,(rename 'CAR) ,expression))
+ `(,(rename 'car) ,expression))
(loop (cdr pattern)
- `(,(rename 'CDR) ,expression)))))))
+ `(,(rename 'cdr) ,expression)))))))
(if (identifier? expression)
(generate-pair expression)
- (let ((temp (rename 'TEMP)))
- `((,(rename 'LAMBDA) (,temp) ,(generate-pair temp))
+ (let ((temp (rename 'temp)))
+ `((,(rename 'lambda) (,temp) ,(generate-pair temp))
,expression)))))
((null? pattern)
- `(,(rename 'NULL?) ,expression))
+ `(,(rename 'null?) ,expression))
(else
- `(,(rename 'EQUAL?) ,expression
- (,(rename 'QUOTE) ,pattern))))))
+ `(,(rename 'equal?) ,expression
+ (,(rename 'quote) ,pattern))))))
(do-list
(lambda (pattern expression)
- (let ((r-loop (rename 'LOOP))
- (r-l (rename 'L))
- (r-lambda (rename 'LAMBDA)))
+ (let ((r-loop (rename 'loop))
+ (r-l (rename 'l))
+ (r-lambda (rename 'lambda)))
`(((,r-lambda
()
- (,(rename 'DEFINE)
+ (,(rename 'define)
,r-loop
(,r-lambda
(,r-l)
- (,(rename 'IF)
- (,(rename 'NULL?) ,r-l)
- #T
+ (,(rename 'if)
+ (,(rename 'null?) ,r-l)
+ #t
,(conjunction
- `(,(rename 'PAIR?) ,r-l)
- (conjunction (loop pattern `(,(rename 'CAR) ,r-l))
- `(,r-loop (,(rename 'CDR) ,r-l)))))))
+ `(,(rename 'pair?) ,r-l)
+ (conjunction (loop pattern `(,(rename 'car) ,r-l))
+ `(,r-loop (,(rename 'cdr) ,r-l)))))))
,r-loop))
,expression))))
(conjunction
(lambda (predicate consequent)
- (cond ((eq? predicate #T) consequent)
- ((eq? consequent #T) predicate)
- (else `(,(rename 'IF) ,predicate ,consequent #F))))))
+ (cond ((eq? predicate #t) consequent)
+ ((eq? consequent #t) predicate)
+ (else `(,(rename 'if) ,predicate ,consequent #f))))))
(loop pattern expression)))
\f
(define (generate-output rename compare r-rename sids template)
(loop (car template) ellipses)
(loop (cdr template) ellipses)))
(else
- `(,(rename 'QUOTE) ,template)))))
+ `(,(rename 'quote) ,template)))))
(define (add-control! sid ellipses)
(let loop ((sid sid) (ellipses ellipses))
(pair? (cdr body))
(eq? (cadr body) name)
(null? (cddr body)))
- `(,(rename 'MAP) ,(car body) ,expression))
+ `(,(rename 'map) ,(car body) ,expression))
(else
- `(,(rename 'MAP) (,(rename 'LAMBDA) ,(map sid-name sids)
+ `(,(rename 'map) (,(rename 'lambda) ,(map sid-name sids)
,body)
,@(map sid-expression sids)))))
(syntax-error "Missing ellipsis in expansion." #f))))
(define (optimized-cons rename compare a d)
(cond ((and (pair? d)
- (compare (car d) (rename 'QUOTE))
+ (compare (car d) (rename 'quote))
(pair? (cdr d))
(null? (cadr d))
(null? (cddr d)))
- `(,(rename 'LIST) ,a))
+ `(,(rename 'list) ,a))
((and (pair? d)
- (compare (car d) (rename 'LIST))
+ (compare (car d) (rename 'list))
(list? (cdr d)))
`(,(car d) ,a ,@(cdr d)))
(else
- `(,(rename 'CONS) ,a ,d))))
+ `(,(rename 'cons) ,a ,d))))
(define (optimized-append rename compare x y)
(if (and (pair? y)
- (compare (car y) (rename 'QUOTE))
+ (compare (car y) (rename 'quote))
(pair? (cdr y))
(null? (cadr y))
(null? (cddr y)))
x
- `(,(rename 'APPEND) ,x ,y)))
+ `(,(rename 'append) ,x ,y)))
(define-record-type <sid>
(make-sid name expression control)
(let ((names
(map (lambda (n) (symbol 'a n))
(iota (procedure-arity-min arity) 1))))
- `(DEFINE-INTEGRABLE (,variable-name ,@names)
+ `(define-integrable (,variable-name ,@names)
(,primitive ,@names)))
- `(DEFINE-INTEGRABLE ,variable-name
+ `(define-integrable ,variable-name
,primitive)))))))
- `(BEGIN ,@(map (lambda (name)
+ `(begin ,@(map (lambda (name)
(cond ((not (pair? name))
(primitive-definition name (list name)))
((not (symbol? (cadr name)))
(let ((p-name (symbol root '?))
(g-name (symbol 'guarantee- root))
(e-name (symbol 'error:not- root)))
- `(BEGIN
- (DEFINE (,g-name OBJECT #!OPTIONAL CALLER)
- (DECLARE (INTEGRATE CALLER))
- (IF (NOT (,(close-syntax p-name environment) OBJECT))
- (,(close-syntax e-name environment) OBJECT CALLER))
- OBJECT)
- (DEFINE (,e-name OBJECT #!OPTIONAL CALLER)
- (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,desc CALLER)))))
+ `(begin
+ (define (,g-name object #!optional caller)
+ (declare (integrate caller))
+ (if (not (,(close-syntax p-name environment) object))
+ (,(close-syntax e-name environment) object caller))
+ object)
+ (define (,e-name object #!optional caller)
+ (error:wrong-type-argument object ,desc caller)))))
(ill-formed-syntax form)))))
(define-syntax define-deferred
(define-structure (thread
(constructor %make-thread (properties))
(conc-name thread/))
- (execution-state 'RUNNING)
+ (execution-state 'running)
;; One of:
;; RUNNING
;; RUNNING-WITHOUT-PREEMPTION
(properties #f read-only #t))
(define no-exit-value-marker
- (list 'NO-EXIT-VALUE-MARKER))
+ (list 'no-exit-value-marker))
(define (thread-dead? thread)
- (guarantee thread? thread 'THREAD-DEAD?)
- (eq? 'DEAD (thread/execution-state thread)))
+ (guarantee thread? thread 'thread-dead?)
+ (eq? 'dead (thread/execution-state thread)))
\f
(define thread-population)
(define first-running-thread)
(add-event-receiver! event:after-restore reset-threads!)
(add-event-receiver! event:before-exit stop-thread-timer)
(named-structure/set-tag-description! thread-mutex-tag
- (make-define-structure-type 'VECTOR
+ (make-define-structure-type 'vector
"thread-mutex"
- '#(WAITING-THREADS OWNER)
+ '#(waiting-threads owner)
'#(1 2)
(vector 2 (lambda () #f))
- (standard-unparser-method 'THREAD-MUTEX #f)
+ (standard-unparser-method 'thread-mutex #f)
thread-mutex-tag
3))
(named-structure/set-tag-description! link-tag
- (make-define-structure-type 'VECTOR
+ (make-define-structure-type 'vector
"link"
- '#(PREV NEXT ITEM)
+ '#(prev next item)
'#(1 2 3)
(vector 3 (lambda () #f))
- (standard-unparser-method 'LINK #f)
+ (standard-unparser-method 'link #f)
link-tag
4)))
(define (reset-threads-low!)
(set! enable-smp?
- (and ((ucode-primitive get-primitive-address 2) 'SMP-COUNT #f)
+ (and ((ucode-primitive get-primitive-address 2) 'smp-count #f)
((ucode-primitive smp-count 0)))))
(define (reset-threads-high!)
(map-over-population thread-population (lambda (thread) thread)))
(define (thread-execution-state thread)
- (guarantee thread? thread 'THREAD-EXECUTION-STATE)
+ (guarantee thread? thread 'thread-execution-state)
(thread/execution-state thread))
(define (create-thread root-continuation thunk)
(let ((condition
(make-condition condition-type:no-current-thread
continuation
- 'BOUND-RESTARTS
+ 'bound-restarts
'())))
(signal-thread-event thread
(lambda ()
(thread/next (current-thread)))
(define (thread-continuation thread)
- (guarantee thread? thread 'THREAD-CONTINUATION)
+ (guarantee thread? thread 'thread-continuation)
(without-interrupts
(lambda ()
- (and (eq? 'WAITING (thread/execution-state thread))
+ (and (eq? 'waiting (thread/execution-state thread))
(thread/continuation thread)))))
(define (thread-running thread)
(%maybe-toggle-thread-timer))
(define (%thread-running thread)
- (set-thread/execution-state! thread 'RUNNING)
+ (set-thread/execution-state! thread 'running)
(let ((prev last-running-thread))
(if prev
(set-thread/next! prev thread)
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
(account-for-times thread (get-system-times))
- (thread-not-running thread 'WAITING)))))))))
+ (thread-not-running thread 'waiting)))))))))
(define (stop-current-thread)
(without-interrupts
(set-thread/continuation! thread continuation)
(maybe-save-thread-float-environment! thread)
(account-for-times thread (get-system-times))
- (thread-not-running thread 'STOPPED))))))))
+ (thread-not-running thread 'stopped))))))))
(define (restart-thread thread discard-events? event)
- (guarantee thread? thread 'RESTART-THREAD)
+ (guarantee thread? thread 'restart-thread)
(let ((discard-events?
- (if (eq? discard-events? 'ASK)
+ (if (eq? discard-events? 'ask)
(prompt-for-confirmation
"Restarting other thread; discard events in its queue")
discard-events?)))
(without-interrupts
(lambda ()
- (if (not (eq? 'STOPPED (thread/execution-state thread)))
+ (if (not (eq? 'stopped (thread/execution-state thread)))
(error:bad-range-argument thread restart-thread))
(if discard-events? (ring/discard-all (thread/pending-events thread)))
(if event (%signal-thread-event thread event))
(thread-running thread)))))
\f
(define (disallow-preempt-current-thread)
- (set-thread/execution-state! (current-thread) 'RUNNING-WITHOUT-PREEMPTION))
+ (set-thread/execution-state! (current-thread) 'running-without-preemption))
(define (allow-preempt-current-thread)
- (set-thread/execution-state! (current-thread) 'RUNNING))
+ (set-thread/execution-state! (current-thread) 'running))
(define (thread-timer-interrupt-handler)
;; Preserve the floating-point environment here to guarantee that the
(%maybe-toggle-thread-timer))
((thread/continuation thread)
(run-thread thread))
- ((not (eq? 'RUNNING-WITHOUT-PREEMPTION
+ ((not (eq? 'running-without-preemption
(thread/execution-state thread)))
(yield-thread thread fp-env))
(else
(account-for-times thread (get-system-times))
;; Allow preemption now, since the current thread has
;; volunteered to yield control.
- (set-thread/execution-state! thread 'RUNNING)
+ (set-thread/execution-state! thread 'running)
(maybe-signal-io-thread-events)
(yield-thread thread))))))
(%disassociate-thread-mutexes thread)
(if (eq? no-exit-value-marker (thread/exit-value thread))
(release-joined-threads thread value))
- (thread-not-running thread 'DEAD)))
+ (thread-not-running thread 'dead)))
(define (join-thread thread event-constructor)
- (guarantee thread? thread 'JOIN-THREAD)
+ (guarantee thread? thread 'join-thread)
(let ((self (current-thread)))
(if (eq? thread self)
(signal-thread-deadlock self "join thread" join-thread thread)
(event-constructor thread value))))))))))
(define (detach-thread thread)
- (guarantee thread? thread 'DETACH-THREAD)
+ (guarantee thread? thread 'detach-thread)
(without-interrupts
(lambda ()
(if (eq? (thread/exit-value thread) detached-thread-marker)
(release-joined-threads thread detached-thread-marker))))
(define detached-thread-marker
- (list 'DETACHED-THREAD-MARKER))
+ (list 'detached-thread-marker))
(define (release-joined-threads thread value)
(set-thread/exit-value! thread value)
(signal-io-thread-events (vector-ref result 0)
(vector-ref result 1)
(vector-ref result 2)))
- ((eq? 'PROCESS-STATUS-CHANGE result)
+ ((eq? 'process-status-change result)
(%handle-subprocess-status-change))))
(define (maybe-signal-io-thread-events)
(signal-select-result (test-select-registry io-registry #f))))
(define (block-on-io-descriptor descriptor mode)
- (let ((result 'INTERRUPT)
+ (let ((result 'interrupt)
(registration #f))
(dynamic-wind
(lambda ()
(lambda ()
(with-thread-events-blocked
(lambda ()
- (if (eq? result 'INTERRUPT)
+ (if (eq? result 'interrupt)
(suspend-current-thread)))))
(lambda ()
(if (and registration
(named-lambda (permanent-io-event mode*)
(if (not stop?)
(event mode*))
- (if (not (or stop? (memq mode* '(ERROR HANGUP #F))))
+ (if (not (or stop? (memq mode* '(error hangup #f))))
(register))))
(register
(lambda ()
(deregister-io-thread-event registration)
(set! registration #f))))))
(register)
- (cons 'DEREGISTER-PERMANENT-IO-EVENT
+ (cons 'deregister-permanent-io-event
(lambda ()
(set! stop? #t)
(deregister))))))
(define (register-io-thread-event descriptor mode thread event)
- (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT)
- (guarantee thread? thread 'REGISTER-IO-THREAD-EVENT)
+ (guarantee-select-mode mode 'register-io-thread-event)
+ (guarantee thread? thread 'register-io-thread-event)
(without-interrupts
(lambda ()
(let ((registration
\f
(define (deregister-io-thread-event registration)
(if (and (pair? registration)
- (eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT))
+ (eq? (car registration) 'deregister-permanent-io-event))
((cdr registration))
(deregister-io-thread-event* registration)))
(define (deregister-io-thread-event* tentry)
(if (not (tentry? tentry))
(error:wrong-type-argument tentry "IO thread event registration"
- 'DEREGISTER-IO-THREAD-EVENT))
+ 'deregister-io-thread-event))
(without-interrupts
(lambda ()
(%deregister-io-thread-event tentry)
(%maybe-toggle-thread-timer))))
(define (deregister-io-descriptor-events descriptor mode)
- (guarantee-select-mode mode 'DEREGISTER-IO-DESCRIPTOR-EVENTS)
+ (guarantee-select-mode mode 'deregister-io-descriptor-events)
(without-interrupts
(lambda ()
(let loop ((dentry io-registrations))
tentries))))))))
(define (guarantee-select-mode mode procedure)
- (if (not (memq mode '(READ WRITE READ-WRITE)))
+ (if (not (memq mode '(read write read-write)))
(error:wrong-type-argument mode "select mode" procedure)))
(define (signal-io-thread-events n vfd vmode)
(search
descriptor
(case mode
- ((READ) (lambda (mode) (memq mode '(READ READ/WRITE))))
- ((WRITE) (lambda (mode) (memq mode '(WRITE READ/WRITE))))
+ ((READ) (lambda (mode) (memq mode '(read read/write))))
+ ((WRITE) (lambda (mode) (memq mode '(write read/write))))
((READ/WRITE) (lambda (mode) mode))
((ERROR HANGUP) (lambda (mode) mode #t))
(else (error "Illegal mode:" mode))))))
(let ((value (thunk)))
(set-interrupt-enables! interrupt-mask/gc-ok)
value))
- 'WITH-THREAD-EVENTS-BLOCKED
+ 'with-thread-events-blocked
block-events?)))
(let ((thread first-running-thread))
(if thread
unspecific)))
\f
(define (signal-thread-event thread event #!optional no-error?)
- (guarantee thread? thread 'SIGNAL-THREAD-EVENT)
+ (guarantee thread? thread 'signal-thread-event)
(let ((self first-running-thread)
(noerr? (and (not (default-object? no-error?))
no-error?)))
(unblock-thread-events)))
(without-interrupts
(lambda ()
- (if (eq? 'DEAD (thread/execution-state thread))
+ (if (eq? 'dead (thread/execution-state thread))
(if (not noerr?)
(signal-thread-dead thread "signal event to"
signal-thread-event thread event))
(define (%signal-thread-event thread event)
(%add-pending-event thread event)
(if (and (not (eq? #t (thread/block-events? thread)))
- (eq? 'WAITING (thread/execution-state thread)))
+ (eq? 'waiting (thread/execution-state thread)))
(%thread-running thread)))
(define (%add-pending-event thread event)
(define (deregister-time-event registration)
(if (not (timer-record? registration))
(error:wrong-type-argument registration "timer event registration"
- 'DEREGISTER-TIMER-EVENT))
+ 'deregister-timer-event))
(without-interrupts
(lambda ()
(let loop ((record timer-records) (prev #f))
(define (set-thread-timer-interval! interval)
(if interval
- (guarantee exact-positive-integer? interval 'SET-THREAD-TIMER-INTERVAL!))
+ (guarantee exact-positive-integer? interval 'set-thread-timer-interval!))
(without-interrupts
(lambda ()
(set! timer-interval interval)
(error:wrong-type-argument mutex "thread-mutex" procedure)))
(define (assert-thread-mutex-owned mutex #!optional caller)
- (guarantee-thread-mutex mutex 'ASSERT-THREAD-MUTEX-OWNED)
+ (guarantee-thread-mutex mutex 'assert-thread-mutex-owned)
(if (not (eq? (current-thread) (thread-mutex/owner mutex)))
(if (default-object? caller)
(error "Don't own mutex:" mutex)
;;; own a mutex so you're less tempted to call THREAD-MUTEX-OWNER ever.
(define (thread-mutex-owner mutex)
- (guarantee-thread-mutex mutex 'THREAD-MUTEX-OWNER)
+ (guarantee-thread-mutex mutex 'thread-mutex-owner)
(thread-mutex/owner mutex))
\f
(define (lock-thread-mutex mutex)
- (guarantee-thread-mutex mutex 'LOCK-THREAD-MUTEX)
+ (guarantee-thread-mutex mutex 'lock-thread-mutex)
(without-interrupts
(lambda ()
(let ((thread (current-thread))
(set-thread-mutex/owner! mutex thread)))
(define (unlock-thread-mutex mutex)
- (guarantee-thread-mutex mutex 'UNLOCK-THREAD-MUTEX)
+ (guarantee-thread-mutex mutex 'unlock-thread-mutex)
(without-interrupts
(lambda ()
(let ((owner (thread-mutex/owner mutex)))
thread))
(define (try-lock-thread-mutex mutex)
- (guarantee-thread-mutex mutex 'TRY-LOCK-THREAD-MUTEX)
+ (guarantee-thread-mutex mutex 'try-lock-thread-mutex)
(without-interrupts
(lambda ()
(and (not (thread-mutex/owner mutex))
#t)))))))
\f
(define (with-thread-mutex-lock mutex thunk)
- (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCK)
+ (guarantee-thread-mutex mutex 'with-thread-mutex-lock)
(dynamic-wind (lambda () (lock-thread-mutex mutex))
thunk
(lambda () (unlock-thread-mutex mutex))))
(define (without-thread-mutex-lock mutex thunk)
- (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCK)
+ (guarantee-thread-mutex mutex 'with-thread-mutex-lock)
(dynamic-wind (lambda () (unlock-thread-mutex mutex))
thunk
(lambda () (lock-thread-mutex mutex))))
(define (with-thread-mutex-try-lock mutex locked not-locked)
- (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-TRY-LOCK)
+ (guarantee-thread-mutex mutex 'with-thread-mutex-try-lock)
(let ((locked?))
(dynamic-wind (lambda ()
(set! locked? (try-lock-thread-mutex mutex)))
;;; mistakes.
(define (with-thread-mutex-locked mutex thunk)
- (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-LOCKED)
+ (guarantee-thread-mutex mutex 'with-thread-mutex-locked)
(let ((thread (current-thread))
(grabbed-lock?))
(dynamic-wind
(%unlock-thread-mutex mutex thread))))))
(define (with-thread-mutex-unlocked mutex thunk)
- (guarantee-thread-mutex mutex 'WITH-THREAD-MUTEX-UNLOCKED)
+ (guarantee-thread-mutex mutex 'with-thread-mutex-unlocked)
(let ((thread (current-thread))
(released-lock?))
(dynamic-wind
(define (initialize-error-conditions!)
(set! condition-type:thread-control-error
- (make-condition-type 'THREAD-CONTROL-ERROR condition-type:control-error
- '(THREAD)
+ (make-condition-type 'thread-control-error condition-type:control-error
+ '(thread)
(lambda (condition port)
(write-string "Anonymous error associated with " port)
(write (thread-control-error/thread condition) port)
(write-string "." port))))
(set! thread-control-error/thread
- (condition-accessor condition-type:thread-control-error 'THREAD))
+ (condition-accessor condition-type:thread-control-error 'thread))
(set! condition-type:thread-deadlock
- (make-condition-type 'THREAD-DEADLOCK
+ (make-condition-type 'thread-deadlock
condition-type:thread-control-error
- '(DESCRIPTION OPERATOR OPERAND)
+ '(description operator operand)
(lambda (condition port)
(write-string "Deadlock detected while trying to " port)
(write-string (thread-deadlock/description condition) port)
(write-string "." port))))
(set! signal-thread-deadlock
(condition-signaller condition-type:thread-deadlock
- '(THREAD DESCRIPTION OPERATOR OPERAND)
+ '(thread description operator operand)
standard-error-handler))
(set! thread-deadlock/description
- (condition-accessor condition-type:thread-deadlock 'DESCRIPTION))
+ (condition-accessor condition-type:thread-deadlock 'description))
(set! thread-deadlock/operator
- (condition-accessor condition-type:thread-deadlock 'OPERATOR))
+ (condition-accessor condition-type:thread-deadlock 'operator))
(set! thread-deadlock/operand
- (condition-accessor condition-type:thread-deadlock 'OPERAND))
+ (condition-accessor condition-type:thread-deadlock 'operand))
\f
(set! condition-type:thread-detached
- (make-condition-type 'THREAD-DETACHED
+ (make-condition-type 'thread-detached
condition-type:thread-control-error
'()
(lambda (condition port)
(write-string "." port))))
(set! signal-thread-detached
(condition-signaller condition-type:thread-detached
- '(THREAD)
+ '(thread)
standard-error-handler))
(set! condition-type:thread-dead
- (make-condition-type 'THREAD-DEAD condition-type:thread-control-error
- '(VERB OPERATOR OPERANDS)
+ (make-condition-type 'thread-dead condition-type:thread-control-error
+ '(verb operator operands)
(lambda (condition port)
(write-string "Unable to " port)
(write-string (thread-dead/verb condition) port)
(set! signal-thread-dead
(let ((signaller
(condition-signaller condition-type:thread-dead
- '(THREAD VERB OPERATOR OPERANDS)
+ '(thread verb operator operands)
standard-error-handler)))
(lambda (thread verb operator . operands)
(signaller thread verb operator operands))))
(set! thread-dead/verb
- (condition-accessor condition-type:thread-dead 'VERB))
+ (condition-accessor condition-type:thread-dead 'verb))
(set! condition-type:no-current-thread
- (make-condition-type 'NO-CURRENT-THREAD condition-type:control-error
+ (make-condition-type 'no-current-thread condition-type:control-error
'()
(lambda (condition port)
condition
(define (make-unix-host-type index)
(make-host-type index
- 'UNIX
+ 'unix
unix/parse-namestring
unix/pathname->namestring
unix/make-pathname
unix/pathname-simplify))
(define (initialize-package!)
- (add-pathname-host-type! 'UNIX make-unix-host-type))
+ (add-pathname-host-type! 'unix make-unix-host-type))
\f
;;;; Pathname Parser
(parse-name (car (last-pair components))
(lambda (name type)
(%make-pathname host
- 'UNSPECIFIC
+ 'unspecific
(let ((components (except-last-pair components)))
(and (pair? components)
(simplify-directory
(if (fix:= 0
(string-length (car components)))
- (cons 'ABSOLUTE
+ (cons 'absolute
(parse-directory-components
(cdr components)))
- (cons 'RELATIVE
+ (cons 'relative
(parse-directory-components
components))))))
name
type
- 'UNSPECIFIC))))))
+ 'unspecific))))))
(define (expand-directory-prefixes components)
(let ((string (car components))
(else components))))))
\f
(define (simplify-directory directory)
- (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory)))
+ (if (and (eq? (car directory) 'relative) (null? (cdr directory)))
#f
directory))
components)))
(define (parse-directory-component component)
- (cond ((string=? ".." component) 'UP)
- ((string=? "." component) 'HERE)
+ (cond ((string=? ".." component) 'up)
+ ((string=? "." component) 'here)
(else component)))
(define (string-components string delimiter)
(fix:= dot (fix:- end 1))
(char=? #\. (string-ref string (fix:- dot 1))))
(receiver (cond ((fix:= end 0) #f)
- ((string=? "*" string) 'WILD)
+ ((string=? "*" string) 'wild)
(else string))
#f)
(receiver (extract string 0 dot)
(define (extract string start end)
(if (and (fix:= 1 (fix:- end start))
(char=? #\* (string-ref string start)))
- 'WILD
+ 'wild
(substring string start end)))
\f
;;;; Pathname Unparser
"")
((pair? directory)
(string-append
- (if (eq? (car directory) 'ABSOLUTE) "/" "")
+ (if (eq? (car directory) 'absolute) "/" "")
(let loop ((directory (cdr directory)))
(if (not (pair? directory))
""
(error:illegal-pathname-component directory "directory"))))
(define (unparse-directory-component component)
- (cond ((eq? component 'UP) "..")
- ((eq? component 'HERE) ".")
+ (cond ((eq? component 'up) "..")
+ ((eq? component 'here) ".")
((string? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
(define (unparse-component component)
(cond ((or (not component) (string? component)) component)
- ((eq? component 'WILD) "*")
+ ((eq? component 'wild) "*")
(else (error:illegal-pathname-component component "component"))))
\f
;;;; Pathname Constructors
(define (unix/make-pathname host device directory name type version)
(%make-pathname
host
- (if (memq device '(#F UNSPECIFIC))
- 'UNSPECIFIC
+ (if (memq device '(#f unspecific))
+ 'unspecific
(error:illegal-pathname-component device "device"))
(cond ((not directory)
directory)
((and (pair? directory)
- (memq (car directory) '(RELATIVE ABSOLUTE))
+ (memq (car directory) '(relative absolute))
(list-of-type? (cdr directory)
(lambda (element)
(if (string? element)
(not (fix:= 0 (string-length element)))
- (memq element '(UP HERE))))))
+ (memq element '(up here))))))
(simplify-directory directory))
(else
(error:illegal-pathname-component directory "directory")))
- (if (or (memq name '(#F WILD))
+ (if (or (memq name '(#f wild))
(and (string? name) (not (fix:= 0 (string-length name)))))
name
(error:illegal-pathname-component name "name"))
- (if (or (memq type '(#F WILD))
+ (if (or (memq type '(#f wild))
(and (string? type) (not (fix:= 0 (string-length type)))))
type
(error:illegal-pathname-component type "type"))
- (if (memq version '(#F UNSPECIFIC WILD NEWEST))
- 'UNSPECIFIC
+ (if (memq version '(#f unspecific wild newest))
+ 'unspecific
(error:illegal-pathname-component version "version"))))
(define (unix/directory-pathname? pathname)
(%pathname-directory pathname)
#f
#f
- 'UNSPECIFIC))
+ 'unspecific))
(define (unix/file-pathname pathname)
(%make-pathname (%pathname-host pathname)
- 'UNSPECIFIC
+ 'unspecific
#f
(%pathname-name pathname)
(%pathname-type pathname)
(if (or name type)
(%make-pathname
(%pathname-host pathname)
- 'UNSPECIFIC
+ 'unspecific
(let ((directory (%pathname-directory pathname))
(component
(parse-directory-component (unparse-name name type))))
(cond ((not (pair? directory))
- (list 'RELATIVE component))
+ (list 'relative component))
((equal? component ".")
directory)
(else
(append directory (list component)))))
#f
#f
- 'UNSPECIFIC)
+ 'unspecific)
pathname)))
(define (unix/directory-pathname-as-file pathname)
(let ((directory (%pathname-directory pathname)))
(if (not (and (pair? directory)
- (or (eq? 'ABSOLUTE (car directory))
+ (or (eq? 'absolute (car directory))
(pair? (cdr directory)))))
- (error:bad-range-argument pathname 'DIRECTORY-PATHNAME-AS-FILE))
+ (error:bad-range-argument pathname 'directory-pathname-as-file))
(if (or (%pathname-name pathname)
(%pathname-type pathname)
(not (pair? (cdr directory))))
(parse-name (unparse-directory-component (car (last-pair directory)))
(lambda (name type)
(%make-pathname (%pathname-host pathname)
- 'UNSPECIFIC
+ 'unspecific
(simplify-directory (except-last-pair directory))
name
type
- 'UNSPECIFIC))))))
+ 'unspecific))))))
\f
;;;; Miscellaneous
(define (unix/pathname-wild? pathname)
- (or (eq? 'WILD (%pathname-name pathname))
- (eq? 'WILD (%pathname-type pathname))))
+ (or (eq? 'wild (%pathname-name pathname))
+ (eq? 'wild (%pathname-type pathname))))
(define (unix/pathname->truename pathname)
(if (file-exists-direct? pathname)
(let ((directory (pathname-directory pathname)))
(let scan ((p (list-tail directory np)) (np np))
(if (pair? p)
- (cond ((and (not (eq? (car p) 'UP))
+ (cond ((and (not (eq? (car p) 'up))
(pair? (cdr p))
- (eq? (cadr p) 'UP))
+ (eq? (cadr p) 'up))
(let ((pathname*
(pathname-new-directory pathname
(delete-up directory p))))
(directory-pathname pathname*))
(loop pathname* np)
(scan (cddr p) (+ np 2)))))
- ((eq? (car p) 'HERE)
+ ((eq? (car p) 'here)
(let ((pathname*
(pathname-new-directory pathname
(delete-here directory p))))
(make-pathname (pathname-host pattern)
(pathname-device pattern)
(pathname-directory pattern)
- 'WILD
- 'WILD
+ 'wild
+ 'wild
(pathname-version pattern))
pattern))))
(let ((directory-path (directory-pathname pattern)))
(list (cons *expand-directory-prefixes?* false))
(lambda ()
(map ->pathname fnames))))))
- (if (and (eq? (pathname-name pattern) 'WILD)
- (eq? (pathname-type pattern) 'WILD))
+ (if (and (eq? (pathname-name pattern) 'wild)
+ (eq? (pathname-type pattern) 'wild))
pathnames
(list-transform-positive pathnames
(lambda (instance)
result))))))
(define (match-component pattern instance)
- (or (eq? pattern 'WILD)
- (eq? pattern #F)
+ (or (eq? pattern 'wild)
+ (eq? pattern #f)
(equal? pattern instance)))
(define (pathname<? x y)
(define (make-uri scheme authority path query fragment)
(let ((path (if (equal? path '("")) '() path)))
- (if scheme (guarantee uri-scheme? scheme 'MAKE-URI))
- (if authority (guarantee uri-authority? authority 'MAKE-URI))
- (guarantee uri-path? path 'MAKE-URI)
- (if query (guarantee string? query 'MAKE-URI))
- (if fragment (guarantee string? fragment 'MAKE-URI))
+ (if scheme (guarantee uri-scheme? scheme 'make-uri))
+ (if authority (guarantee uri-authority? authority 'make-uri))
+ (guarantee uri-path? path 'make-uri)
+ (if query (guarantee string? query 'make-uri))
+ (if fragment (guarantee string? fragment 'make-uri))
(if (and authority (pair? path) (path-relative? path))
- (error:bad-range-argument path 'MAKE-URI))
+ (error:bad-range-argument path 'make-uri))
(let* ((path (remove-dot-segments path))
(string
(call-with-output-string
(list-of-type? object string?))
(define (uri-path-absolute? path)
- (guarantee uri-path? path 'URI-PATH-ABSOLUTE?)
+ (guarantee uri-path? path 'uri-path-absolute?)
(path-absolute? path))
(define (path-absolute? path)
(fix:= 0 (string-length (car path)))))
(define (uri-path-relative? path)
- (guarantee uri-path? path 'URI-PATH-RELATIVE?)
+ (guarantee uri-path? path 'uri-path-relative?)
(path-relative? path))
(define-integrable (path-relative? path)
(write-uri-authority authority port)))))))
(define (make-uri-authority userinfo host port)
- (if userinfo (guarantee uri-userinfo? userinfo 'MAKE-URI-AUTHORITY))
- (guarantee uri-host? host 'MAKE-URI-AUTHORITY)
- (if port (guarantee uri-port? port 'MAKE-URI-AUTHORITY))
+ (if userinfo (guarantee uri-userinfo? userinfo 'make-uri-authority))
+ (guarantee uri-host? host 'make-uri-authority)
+ (if port (guarantee uri-port? port 'make-uri-authority))
(hash-table/intern! interned-uri-authorities
(call-with-output-string
(lambda (output)
(define-guarantee uri-port "URI port")
(define (uri=? u1 u2)
- (eq? (->uri u1 'URI=?)
- (->uri u2 'URI=?)))
+ (eq? (->uri u1 'uri=?)
+ (->uri u2 'uri=?)))
(define (uri-authority=? a1 a2)
- (guarantee uri-authority? a1 'URI-AUTHORITY=?)
- (guarantee uri-authority? a2 'URI-AUTHORITY=?)
+ (guarantee uri-authority? a1 'uri-authority=?)
+ (guarantee uri-authority? a2 'uri-authority=?)
(eq? a1 a2))
(define (uri->alist uri)
- (let ((uri (->uri uri 'URI->ALIST)))
+ (let ((uri (->uri uri 'uri->alist)))
`(,@(if (uri-scheme uri)
`((scheme ,(uri-scheme uri)))
'())
'()))))
(define (uri-prefix prefix)
- (guarantee string? prefix 'URI-PREFIX)
+ (guarantee string? prefix 'uri-prefix)
(lambda (suffix)
- (guarantee string? suffix 'URI-PREFIX)
+ (guarantee string? suffix 'uri-prefix)
(string->absolute-uri (string-append prefix suffix))))
\f
(define (remove-dot-segments path)
#f))))
\f
(define (string->uri string #!optional start end)
- (%string->uri parse-uri string start end 'STRING->URI))
+ (%string->uri parse-uri string start end 'string->uri))
(define (string->absolute-uri string #!optional start end)
- (%string->uri parse-absolute-uri string start end 'STRING->ABSOLUTE-URI))
+ (%string->uri parse-absolute-uri string start end 'string->absolute-uri))
(define (string->relative-uri string #!optional start end)
- (%string->uri parse-relative-uri string start end 'STRING->RELATIVE-URI))
+ (%string->uri parse-relative-uri string start end 'string->relative-uri))
(define (%string->uri parser string start end caller)
(or (and (string? string)
(write-partial-uri puri port))))
(define (write-partial-uri puri port)
- (guarantee partial-uri? puri 'WRITE-PARTIAL-URI)
+ (guarantee partial-uri? puri 'write-partial-uri)
(let ((write-component
(lambda (component prefix suffix)
(if component
(extra partial-uri-extra set-partial-uri-extra!))
(define-unparser-method partial-uri?
- (standard-unparser-method 'PARTIAL-URI
+ (standard-unparser-method 'partial-uri
(lambda (puri port)
(write-char #\space port)
(write-partial-uri puri port))))
(define (partial-uri-state-name puri)
(let ((name (%partial-uri-state-name puri)))
(case name
- ((START-REFERENCE START-ABSOLUTE) 'START)
- ((SCHEME-REFERENCE SCHEME-ABSOLUTE) 'SCHEME)
- ((SEGMENT-NZ-NC) 'PATH)
+ ((START-REFERENCE START-ABSOLUTE) 'start)
+ ((SCHEME-REFERENCE SCHEME-ABSOLUTE) 'scheme)
+ ((SEGMENT-NZ-NC) 'path)
((HIER-PART INIT-SLASH)
- (if (partial-uri-scheme puri) 'HIER-PART 'RELATIVE-PART))
+ (if (partial-uri-scheme puri) 'hier-part 'relative-part))
(else name))))
(define (%partial-uri-state-name puri)
environment
(define (reorder-clauses clauses)
- (let ((eof (assq 'EOF clauses)))
+ (let ((eof (assq 'eof clauses)))
(if eof
(cons eof (delq eof clauses))
- (cons '(EOF) clauses))))
+ (cons '(eof) clauses))))
(define (expand-clause clause)
(let ((key (car clause))
(actions (cdr clause)))
- `(,(cond ((eq? key 'EOF)
- `(EOF-OBJECT? CHAR))
+ `(,(cond ((eq? key 'eof)
+ `(eof-object? char))
((fix:= 1 (string-length (symbol->string key)))
- `(CHAR=? CHAR ,(string-ref (symbol->string key) 0)))
+ `(char=? char ,(string-ref (symbol->string key) 0)))
(else
- `(CHAR-in-SET? CHAR ,(symbol 'CHAR-SET:URI- key))))
+ `(char-in-set? char ,(symbol 'char-set:uri- key))))
,@(map (lambda (action)
(cond ((action:push? action) (expand:push action))
((action:set? action) (expand:set action))
((action:go? action) (expand:go action))
(else (error "Unknown action:" action))))
actions)
- ,@(if (eq? key 'EOF)
- '((PPU-FINISH BUFFER PURI #F))
+ ,@(if (eq? key 'eof)
+ '((ppu-finish buffer puri #f))
'()))))
(define (action:push? action) (syntax-match? '('push ? symbol) action))
(define (expand:push action)
- `(WRITE-CHAR ,(if (pair? (cdr action))
+ `(write-char ,(if (pair? (cdr action))
(string-ref (symbol->string (cadr action)) 0)
- 'CHAR)
- BUFFER))
+ 'char)
+ buffer))
(define (action:set? action) (syntax-match? '('set symbol) action))
(define (expand:set action)
- `(,(symbol 'BUFFER-> (cadr action)) BUFFER PURI))
+ `(,(symbol 'buffer-> (cadr action)) buffer puri))
(define (action:go? action) (symbol? action))
- (define (expand:go action) `(,(symbol 'PPU: action) PORT BUFFER PURI))
+ (define (expand:go action) `(,(symbol 'ppu: action) port buffer puri))
(if (syntax-match? '(symbol + (symbol * datum)) (cdr form))
(let ((state-name (cadr form))
(clauses (cddr form)))
- (let ((name (symbol 'PPU: state-name)))
- `(BEGIN
- (DEFINE (,name PORT BUFFER PURI)
- (SET-PARTIAL-URI-STATE! PURI ,name)
- (LET ((CHAR (READ-CHAR PORT)))
- (COND ,@(map expand-clause (reorder-clauses clauses))
- (ELSE
- (UNREAD-CHAR CHAR PORT)
- (PPU-FINISH BUFFER PURI #T)))))
- (DEFINE-STATE-NAME ',state-name ,name))))
+ (let ((name (symbol 'ppu: state-name)))
+ `(begin
+ (define (,name port buffer puri)
+ (set-partial-uri-state! puri ,name)
+ (let ((char (read-char port)))
+ (cond ,@(map expand-clause (reorder-clauses clauses))
+ (else
+ (unread-char char port)
+ (ppu-finish buffer puri #t)))))
+ (define-state-name ',state-name ,name))))
(ill-formed-syntax form)))))
\f
(define-ppu-state start-reference
;;; relation.
(define-structure
- (tree-type
- (conc-name tree-type/)
- (constructor %make-tree-type))
- (key<? #F read-only true)
- (alist->tree #F read-only true)
- (add #F read-only true)
- (insert! #F read-only true)
- (delete #F read-only true)
- (delete! #F read-only true)
- (member? #F read-only true)
- (lookup #F read-only true)
- ;;;min ; ? also delmin, max, delmax, delmin!, delmax!
- (split-lt #F read-only true)
- (split-gt #F read-only true)
- (union #F read-only true)
- (union-merge #F read-only true)
- (intersection #F read-only true)
- (difference #F read-only true)
- (subset? #F read-only true)
- (rank #F read-only true)
-)
+ (tree-type
+ (conc-name tree-type/)
+ (constructor %make-tree-type))
+ (key<? #f read-only #t)
+ (alist->tree #f read-only #t)
+ (add #f read-only #t)
+ (insert! #f read-only #t)
+ (delete #f read-only #t)
+ (delete! #f read-only #t)
+ (member? #f read-only #t)
+ (lookup #f read-only #t)
+ ;;min ; ? also delmin, max, delmax, delmin!, delmax!
+ (split-lt #f read-only #t)
+ (split-gt #f read-only #t)
+ (union #f read-only #t)
+ (union-merge #f read-only #t)
+ (intersection #f read-only #t)
+ (difference #f read-only #t)
+ (subset? #f read-only #t)
+ (rank #f read-only #t))
\f
;;; Tree representation
;;;
;;; WT-TREE is a wrapper for trees of nodes
;;;
(define-structure
- (wt-tree
- (conc-name tree/)
- (constructor %make-wt-tree))
- (type #F read-only true)
- (root #F read-only false))
+ (wt-tree
+ (conc-name tree/)
+ (constructor %make-wt-tree))
+ (type #f read-only #t)
+ (root #f read-only #f))
;;; Nodes are the thing from which the real trees are built.
(define define-method/always-false?
(expression/make-method-definer always-false?-dispatch-vector))
-(define-method/always-false? 'ACCESS false-procedure)
+(define-method/always-false? 'access false-procedure)
-(define-method/always-false? 'ASSIGNMENT false-procedure)
+(define-method/always-false? 'assignment false-procedure)
-(define-method/always-false? 'COMBINATION
+(define-method/always-false? 'combination
(lambda (expression)
(cond ((expression/call-to-not? expression)
(expression/never-false? (first (combination/operands expression))))
(procedure/body (combination/operator expression))))
(else #f))))
-(define-method/always-false? 'CONDITIONAL
+(define-method/always-false? 'conditional
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
(expression/always-false? (conditional/consequent expression)))
(or (expression/never-false? (conditional/predicate expression))
(expression/always-false? (conditional/alternative expression))))))
-(define-method/always-false? 'CONSTANT
+(define-method/always-false? 'constant
(lambda (expression)
(not (constant/value expression))))
-(define-method/always-false? 'DECLARATION
+(define-method/always-false? 'declaration
(lambda (expression)
(expression/always-false?
(declaration/expression expression))))
;; A promise is not a false value.
-(define-method/always-false? 'DELAY false-procedure)
+(define-method/always-false? 'delay false-procedure)
-(define-method/always-false? 'DISJUNCTION
+(define-method/always-false? 'disjunction
(lambda (expression)
(and (expression/always-false? (disjunction/predicate expression))
(expression/always-false? (disjunction/alternative expression)))))
-(define-method/always-false? 'OPEN-BLOCK
+(define-method/always-false? 'open-block
(lambda (expression)
(expression/always-false?
(last (open-block/actions expression)))))
;; A closure is not a false value.
-(define-method/always-false? 'PROCEDURE false-procedure)
+(define-method/always-false? 'procedure false-procedure)
-(define-method/always-false? 'QUOTATION false-procedure)
+(define-method/always-false? 'quotation false-procedure)
-(define-method/always-false? 'REFERENCE false-procedure)
+(define-method/always-false? 'reference false-procedure)
-(define-method/always-false? 'SEQUENCE
+(define-method/always-false? 'sequence
(lambda (expression)
(expression/always-false?
(last (sequence/actions expression)))))
-(define-method/always-false? 'THE-ENVIRONMENT false-procedure)
+(define-method/always-false? 'the-environment false-procedure)
\f
;;; EXPRESSION/BOOLEAN?
;;
(define define-method/boolean?
(expression/make-method-definer boolean?-dispatch-vector))
-(define-method/boolean? 'ACCESS false-procedure)
+(define-method/boolean? 'access false-procedure)
-(define-method/boolean? 'ASSIGNMENT false-procedure)
+(define-method/boolean? 'assignment false-procedure)
-(define-method/boolean? 'COMBINATION
+(define-method/boolean? 'combination
(lambda (expression)
(or (expression/call-to-boolean-predicate? expression)
(and (procedure? (combination/operator expression))
(boolean? (procedure/body (combination/operator expression)))))))
-(define-method/boolean? 'CONDITIONAL
+(define-method/boolean? 'conditional
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
(expression/boolean? (conditional/consequent expression)))
(or (expression/never-false? (conditional/predicate expression))
(expression/boolean? (conditional/alternative expression))))))
-(define-method/boolean? 'CONSTANT
+(define-method/boolean? 'constant
(lambda (expression)
;; jrm: do not accept unspecific here.
(or (not (constant/value expression))
(eq? (constant/value expression) #t))))
-(define-method/boolean? 'DECLARATION
+(define-method/boolean? 'declaration
(lambda (expression)
(expression/boolean? (declaration/expression expression))))
-(define-method/boolean? 'DELAY false-procedure)
+(define-method/boolean? 'delay false-procedure)
-(define-method/boolean? 'DISJUNCTION
+(define-method/boolean? 'disjunction
(lambda (expression)
(and (expression/boolean? (disjunction/predicate expression))
(or (expression/never-false? (disjunction/predicate expression))
(expression/boolean? (disjunction/alternative expression))))))
-(define-method/boolean? 'OPEN-BLOCK
+(define-method/boolean? 'open-block
(lambda (expression)
(expression/boolean?
(last (open-block/actions expression)))))
-(define-method/boolean? 'PROCEDURE false-procedure)
+(define-method/boolean? 'procedure false-procedure)
-(define-method/boolean? 'QUOTATION false-procedure)
+(define-method/boolean? 'quotation false-procedure)
-(define-method/boolean? 'REFERENCE false-procedure)
+(define-method/boolean? 'reference false-procedure)
-(define-method/boolean? 'SEQUENCE
+(define-method/boolean? 'sequence
(lambda (expression)
(expression/boolean? (last (sequence/actions expression)))))
-(define-method/boolean? 'THE-ENVIRONMENT false-procedure)
+(define-method/boolean? 'the-environment false-procedure)
\f
;;; EXPRESSION/EFFECT-FREE?
;;
(define define-method/effect-free?
(expression/make-method-definer effect-free?-dispatch-vector))
-(define-method/effect-free? 'ACCESS
+(define-method/effect-free? 'access
(lambda (expression)
(expression/effect-free? (access/environment expression))))
-(define-method/effect-free? 'ASSIGNMENT false-procedure)
+(define-method/effect-free? 'assignment false-procedure)
-(define-method/effect-free? 'COMBINATION
+(define-method/effect-free? 'combination
(lambda (expression)
(and (every expression/effect-free? (combination/operands expression))
(or (expression/call-to-effect-free-primitive? expression)
(expression/effect-free?
(procedure/body (combination/operator expression))))))))
-(define-method/effect-free? 'CONDITIONAL
+(define-method/effect-free? 'conditional
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
(or (expression/always-false? (conditional/predicate expression))
(or (expression/never-false? (conditional/predicate expression))
(expression/effect-free? (conditional/alternative expression))))))
-(define-method/effect-free? 'CONSTANT true-procedure)
+(define-method/effect-free? 'constant true-procedure)
-(define-method/effect-free? 'DECLARATION
+(define-method/effect-free? 'declaration
(lambda (expression)
(expression/effect-free? (declaration/expression expression))))
;; Consing a promise is not considered an effect.
-(define-method/effect-free? 'DELAY true-procedure)
+(define-method/effect-free? 'delay true-procedure)
-(define-method/effect-free? 'DISJUNCTION
+(define-method/effect-free? 'disjunction
(lambda (expression)
(and (expression/effect-free? (disjunction/predicate expression))
(or (expression/never-false? (disjunction/predicate expression))
;; This could be smarter and skip the assignments
;; done for the letrec, but it is easier to just
;; assume it causes effects.
-(define-method/effect-free? 'OPEN-BLOCK
+(define-method/effect-free? 'open-block
(lambda (expression)
(declare (ignore expression))
#f))
;; Just consing a closure is not considered a side-effect.
-(define-method/effect-free? 'PROCEDURE true-procedure)
+(define-method/effect-free? 'procedure true-procedure)
-(define-method/effect-free? 'QUOTATION false-procedure)
+(define-method/effect-free? 'quotation false-procedure)
-(define-method/effect-free? 'REFERENCE true-procedure)
+(define-method/effect-free? 'reference true-procedure)
-(define-method/effect-free? 'SEQUENCE
+(define-method/effect-free? 'sequence
(lambda (expression)
(every expression/effect-free? (sequence/actions expression))))
-(define-method/effect-free? 'THE-ENVIRONMENT true-procedure)
+(define-method/effect-free? 'the-environment true-procedure)
\f
;;; EXPRESSION/FREE-VARIABLES
;;
(define define-method/free-variables
(expression/make-method-definer free-variables-dispatch-vector))
-(define-method/free-variables 'ACCESS
+(define-method/free-variables 'access
(lambda (expression)
(expression/free-variables (access/environment expression))))
-(define-method/free-variables 'ASSIGNMENT
+(define-method/free-variables 'assignment
(lambda (expression)
(lset-adjoin eq?
(expression/free-variables (assignment/value expression))
(assignment/variable expression))))
-(define-method/free-variables 'COMBINATION
+(define-method/free-variables 'combination
(lambda (expression)
(lset-union
eq?
(expression/free-variables (combination/operator expression))
(expressions/free-variables (combination/operands expression)))))
-(define-method/free-variables 'CONDITIONAL
+(define-method/free-variables 'conditional
(lambda (expression)
(lset-union
eq?
(no-free-variables)
(expression/free-variables (conditional/alternative expression))))))
-(define-method/free-variables 'CONSTANT
+(define-method/free-variables 'constant
(lambda (expression)
expression
(no-free-variables)))
-(define-method/free-variables 'DECLARATION
+(define-method/free-variables 'declaration
(lambda (expression)
(expression/free-variables (declaration/expression expression))))
\f
-(define-method/free-variables 'DELAY
+(define-method/free-variables 'delay
(lambda (expression)
(expression/free-variables (delay/expression expression))))
-(define-method/free-variables 'DISJUNCTION
+(define-method/free-variables 'disjunction
(lambda (expression)
(lset-union
eq?
(no-free-variables)
(expression/free-variables (disjunction/alternative expression))))))
-(define-method/free-variables 'OPEN-BLOCK
+(define-method/free-variables 'open-block
(lambda (expression)
(let ((omit (block/bound-variables (open-block/block expression))))
(fold-left (lambda (variables action)
omit)
(open-block/actions expression)))))
-(define-method/free-variables 'PROCEDURE
+(define-method/free-variables 'procedure
(lambda (expression)
(lset-difference eq?
(expression/free-variables (procedure/body expression))
(block/bound-variables (procedure/block expression)))))
-(define-method/free-variables 'QUOTATION
+(define-method/free-variables 'quotation
(lambda (expression)
(declare (ignore expression))
(no-free-variables)))
-(define-method/free-variables 'REFERENCE
+(define-method/free-variables 'reference
(lambda (expression)
(singleton-variable (reference/variable expression))))
-(define-method/free-variables 'SEQUENCE
+(define-method/free-variables 'sequence
(lambda (expression)
(expressions/free-variables (sequence/actions expression))))
-(define-method/free-variables 'THE-ENVIRONMENT
+(define-method/free-variables 'the-environment
(lambda (expression)
(declare (ignore expression))
(no-free-variables)))
(define define-method/free-variable?
(expression/make-method-definer is-free-dispatch-vector))
-(define-method/free-variable? 'ACCESS
+(define-method/free-variable? 'access
(lambda (expression variable)
(expression/free-variable? (access/environment expression) variable)))
-(define-method/free-variable? 'ASSIGNMENT
+(define-method/free-variable? 'assignment
(lambda (expression variable)
(or (eq? variable (assignment/variable expression))
(expression/free-variable? (assignment/value expression) variable))))
-(define-method/free-variable? 'COMBINATION
+(define-method/free-variable? 'combination
(lambda (expression variable)
(or (expression/free-variable? (combination/operator expression) variable)
(expressions/free-variable?
(combination/operands expression) variable))))
-(define-method/free-variable? 'CONDITIONAL
+(define-method/free-variable? 'conditional
(lambda (expression variable)
(or (expression/free-variable? (conditional/predicate expression) variable)
(cond ((expression/always-false? (conditional/predicate expression))
(expression/free-variable? (conditional/alternative expression)
variable))))))
-(define-method/free-variable? 'CONSTANT false-procedure)
+(define-method/free-variable? 'constant false-procedure)
-(define-method/free-variable? 'DECLARATION
+(define-method/free-variable? 'declaration
(lambda (expression variable)
(expression/free-variable? (declaration/expression expression) variable)))
\f
-(define-method/free-variable? 'DELAY
+(define-method/free-variable? 'delay
(lambda (expression variable)
(expression/free-variable? (delay/expression expression) variable)))
-(define-method/free-variable? 'DISJUNCTION
+(define-method/free-variable? 'disjunction
(lambda (expression variable)
(or (expression/free-variable? (disjunction/predicate expression) variable)
(if (expression/never-false? (disjunction/predicate expression))
(expression/free-variable? (disjunction/alternative expression)
variable)))))
-(define-method/free-variable? 'OPEN-BLOCK
+(define-method/free-variable? 'open-block
(lambda (expression variable)
(fold-left (lambda (answer action)
(or answer
#f
(open-block/actions expression))))
-(define-method/free-variable? 'PROCEDURE
+(define-method/free-variable? 'procedure
(lambda (expression variable)
(expression/free-variable? (procedure/body expression) variable)))
-(define-method/free-variable? 'QUOTATION false-procedure)
+(define-method/free-variable? 'quotation false-procedure)
-(define-method/free-variable? 'REFERENCE
+(define-method/free-variable? 'reference
(lambda (expression variable)
(eq? (reference/variable expression) variable)))
-(define-method/free-variable? 'SEQUENCE
+(define-method/free-variable? 'sequence
(lambda (expression variable)
(fold-left (lambda (answer action)
(or answer
#f
(sequence/actions expression))))
-(define-method/free-variable? 'THE-ENVIRONMENT false-procedure)
+(define-method/free-variable? 'the-environment false-procedure)
\f
;;; EXPRESSION/FREE-VARIABLE-INFO <expression> <variable>
;;
(define define-method/free-variable-info
(expression/make-method-definer free-info-dispatch-vector))
-(define-method/free-variable-info 'ACCESS
+(define-method/free-variable-info 'access
(lambda (expression variable info)
(expression/free-variable-info-dispatch (access/environment expression)
variable info)))
-(define-method/free-variable-info 'ASSIGNMENT
+(define-method/free-variable-info 'assignment
(lambda (expression variable info)
(or (eq? variable (assignment/variable expression))
(expression/free-variable-info-dispatch (assignment/value expression)
variable info))))
-(define-method/free-variable-info 'COMBINATION
+(define-method/free-variable-info 'combination
(lambda (expression variable info)
(let ((operator (combination/operator expression))
(inner-info
(expression/free-variable-info-dispatch operator variable
inner-info)))))
-(define-method/free-variable-info 'CONDITIONAL
+(define-method/free-variable-info 'conditional
(lambda (expression variable info)
(expression/free-variable-info-dispatch
(conditional/predicate expression) variable
(conditional/alternative expression)
variable info)))))
-(define-method/free-variable-info 'CONSTANT
+(define-method/free-variable-info 'constant
(lambda (expression variable info)
(declare (ignore expression variable))
info))
-(define-method/free-variable-info 'DECLARATION
+(define-method/free-variable-info 'declaration
(lambda (expression variable info)
(expression/free-variable-info-dispatch (declaration/expression expression)
variable info)))
\f
-(define-method/free-variable-info 'DELAY
+(define-method/free-variable-info 'delay
(lambda (expression variable info)
(expression/free-variable-info-dispatch (delay/expression expression)
variable info)))
-(define-method/free-variable-info 'DISJUNCTION
+(define-method/free-variable-info 'disjunction
(lambda (expression variable info)
(expression/free-variable-info-dispatch
(disjunction/predicate expression) variable
(disjunction/alternative expression) variable
info))))
-(define-method/free-variable-info 'OPEN-BLOCK
+(define-method/free-variable-info 'open-block
(lambda (expression variable info)
(fold-left (lambda (info action)
(if (eq? action open-block/value-marker)
info
(open-block/actions expression))))
-(define-method/free-variable-info 'PROCEDURE
+(define-method/free-variable-info 'procedure
(lambda (expression variable info)
(expression/free-variable-info-dispatch (procedure/body expression)
variable info)))
-(define-method/free-variable-info 'QUOTATION
+(define-method/free-variable-info 'quotation
(lambda (expression variable info)
(declare (ignore expression variable))
info))
-(define-method/free-variable-info 'REFERENCE
+(define-method/free-variable-info 'reference
(lambda (expression variable info)
(if (eq? (reference/variable expression) variable)
(cons (car info) (fix:1+ (cdr info)))
info)))
-(define-method/free-variable-info 'SEQUENCE
+(define-method/free-variable-info 'sequence
(lambda (expression variable info)
(expressions/free-variable-info (sequence/actions expression)
variable info)))
-(define-method/free-variable-info 'THE-ENVIRONMENT
+(define-method/free-variable-info 'the-environment
(lambda (expression variable info)
(declare (ignore expression variable))
info))
(define define-method/never-false?
(expression/make-method-definer never-false?-dispatch-vector))
-(define-method/never-false? 'ACCESS false-procedure)
+(define-method/never-false? 'access false-procedure)
-(define-method/never-false? 'ASSIGNMENT false-procedure)
+(define-method/never-false? 'assignment false-procedure)
-(define-method/never-false? 'COMBINATION
+(define-method/never-false? 'combination
(lambda (expression)
(cond ((expression/call-to-not? expression)
(expression/always-false? (first (combination/operands expression))))
(procedure/body (combination/operator expression))))
(else #f))))
-(define-method/never-false? 'CONDITIONAL
+(define-method/never-false? 'conditional
(lambda (expression)
(and (or (expression/always-false? (conditional/predicate expression))
(expression/never-false? (conditional/consequent expression)))
(or (expression/never-false? (conditional/predicate expression))
(expression/never-false? (conditional/alternative expression))))))
-(define-method/never-false? 'CONSTANT constant/value)
+(define-method/never-false? 'constant constant/value)
-(define-method/never-false? 'DECLARATION
+(define-method/never-false? 'declaration
(lambda (expression)
(expression/never-false? (declaration/expression expression))))
-(define-method/never-false? 'DELAY true-procedure)
+(define-method/never-false? 'delay true-procedure)
-(define-method/never-false? 'DISJUNCTION
+(define-method/never-false? 'disjunction
(lambda (expression)
(or (expression/never-false? (disjunction/predicate expression))
(expression/never-false? (disjunction/alternative expression)))))
-(define-method/never-false? 'OPEN-BLOCK
+(define-method/never-false? 'open-block
(lambda (expression)
(expression/never-false?
(last (open-block/actions expression)))))
-(define-method/never-false? 'PROCEDURE true-procedure)
+(define-method/never-false? 'procedure true-procedure)
-(define-method/never-false? 'QUOTATION false-procedure)
+(define-method/never-false? 'quotation false-procedure)
-(define-method/never-false? 'REFERENCE false-procedure)
+(define-method/never-false? 'reference false-procedure)
-(define-method/never-false? 'SEQUENCE
+(define-method/never-false? 'sequence
(lambda (expression)
(expression/never-false? (last (sequence/actions expression)))))
-(define-method/never-false? 'THE-ENVIRONMENT true-procedure)
+(define-method/never-false? 'the-environment true-procedure)
\f
;;; EXPRESSION/PURE-FALSE?
(define define-method/pure-false?
(expression/make-method-definer pure-false?-dispatch-vector))
-(define-method/pure-false? 'ACCESS false-procedure)
+(define-method/pure-false? 'access false-procedure)
-(define-method/pure-false? 'ASSIGNMENT false-procedure)
+(define-method/pure-false? 'assignment false-procedure)
-(define-method/pure-false? 'COMBINATION
+(define-method/pure-false? 'combination
(lambda (expression)
(cond ((expression/call-to-not? expression)
(expression/pure-true? (first (combination/operands expression))))
(procedure/body (combination/operator expression)))))
(else #f))))
-(define-method/pure-false? 'CONDITIONAL
+(define-method/pure-false? 'conditional
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
(or (expression/always-false? (conditional/predicate expression))
(or (expression/never-false? (conditional/predicate expression))
(expression/pure-false? (conditional/alternative expression))))))
-(define-method/pure-false? 'CONSTANT
+(define-method/pure-false? 'constant
(lambda (expression)
(not (constant/value expression))))
-(define-method/pure-false? 'DECLARATION
+(define-method/pure-false? 'declaration
(lambda (expression)
(expression/pure-false?
(declaration/expression expression))))
-(define-method/pure-false? 'DELAY false-procedure)
+(define-method/pure-false? 'delay false-procedure)
-(define-method/pure-false? 'DISJUNCTION
+(define-method/pure-false? 'disjunction
(lambda (expression)
(and (expression/pure-false? (disjunction/predicate expression))
(expression/pure-false? (disjunction/alternative expression)))))
;; Could be smarter
-(define-method/pure-false? 'OPEN-BLOCK false-procedure)
+(define-method/pure-false? 'open-block false-procedure)
-(define-method/pure-false? 'PROCEDURE false-procedure)
+(define-method/pure-false? 'procedure false-procedure)
-(define-method/pure-false? 'QUOTATION false-procedure)
+(define-method/pure-false? 'quotation false-procedure)
-(define-method/pure-false? 'REFERENCE false-procedure)
+(define-method/pure-false? 'reference false-procedure)
-(define-method/pure-false? 'SEQUENCE
+(define-method/pure-false? 'sequence
(lambda (expression)
(and (every expression/effect-free? ; unlikely
(except-last-pair (sequence/actions expression)))
(expression/pure-false? (last (sequence/actions expression))))))
-(define-method/pure-false? 'THE-ENVIRONMENT false-procedure)
+(define-method/pure-false? 'the-environment false-procedure)
\f
;;; EXPRESSION/PURE-TRUE?
;;
(define define-method/pure-true?
(expression/make-method-definer pure-true?-dispatch-vector))
-(define-method/pure-true? 'ACCESS false-procedure)
+(define-method/pure-true? 'access false-procedure)
-(define-method/pure-true? 'ASSIGNMENT false-procedure)
+(define-method/pure-true? 'assignment false-procedure)
-(define-method/pure-true? 'COMBINATION
+(define-method/pure-true? 'combination
(lambda (expression)
(cond ((expression/call-to-not? expression)
(expression/pure-false? (first (combination/operands expression))))
(procedure/body (combination/operator expression)))))
(else #f))))
-(define-method/pure-true? 'CONDITIONAL
+(define-method/pure-true? 'conditional
(lambda (expression)
(and (expression/effect-free? (conditional/predicate expression))
(or (expression/always-false? (conditional/predicate expression))
(or (expression/never-false? (conditional/predicate expression))
(expression/pure-true? (conditional/alternative expression))))))
-(define-method/pure-true? 'CONSTANT
+(define-method/pure-true? 'constant
(lambda (expression)
(eq? (constant/value expression) #t)))
-(define-method/pure-true? 'DECLARATION
+(define-method/pure-true? 'declaration
(lambda (expression)
(expression/pure-true? (declaration/expression expression))))
-(define-method/pure-true? 'DELAY false-procedure)
+(define-method/pure-true? 'delay false-procedure)
-(define-method/pure-true? 'DISJUNCTION
+(define-method/pure-true? 'disjunction
(lambda (expression)
(and (expression/effect-free? (disjunction/predicate expression))
(expression/boolean? (disjunction/predicate expression))
(expression/pure-true? (disjunction/alternative expression)))))
-(define-method/pure-true? 'OPEN-BLOCK false-procedure)
+(define-method/pure-true? 'open-block false-procedure)
-(define-method/pure-true? 'PROCEDURE false-procedure)
+(define-method/pure-true? 'procedure false-procedure)
-(define-method/pure-true? 'QUOTATION false-procedure)
+(define-method/pure-true? 'quotation false-procedure)
-(define-method/pure-true? 'REFERENCE false-procedure)
+(define-method/pure-true? 'reference false-procedure)
-(define-method/pure-true? 'SEQUENCE
+(define-method/pure-true? 'sequence
(lambda (expression)
(and (every expression/effect-free?
(except-last-pair (sequence/actions expression)))
(expression/pure-true? (last (sequence/actions expression))))))
-(define-method/pure-true? 'THE-ENVIRONMENT false-procedure)
+(define-method/pure-true? 'the-environment false-procedure)
\f
;;; EXPRESSION/SIZE <expr>
;;
(define define-method/size
(expression/make-method-definer size-dispatch-vector))
-(define-method/size 'ACCESS
+(define-method/size 'access
(lambda (expression)
(fix:1+ (expression/size (access/environment expression)))))
-(define-method/size 'ASSIGNMENT
+(define-method/size 'assignment
(lambda (expression)
(fix:1+ (expression/size (assignment/value expression)))))
-(define-method/size 'COMBINATION
+(define-method/size 'combination
(lambda (expression)
(fold-left (lambda (total operand)
(fix:+ total (expression/size operand)))
(fix:1+ (expression/size (combination/operator expression)))
(combination/operands expression))))
-(define-method/size 'CONDITIONAL
+(define-method/size 'conditional
(lambda (expression)
(fix:+
(expression/size (conditional/predicate expression))
(expression/size (conditional/consequent expression))
(fix:1+ (expression/size (conditional/alternative expression)))))))
-(define-method/size 'CONSTANT
+(define-method/size 'constant
(lambda (expression) (declare (ignore expression)) 1))
-(define-method/size 'DECLARATION
+(define-method/size 'declaration
(lambda (expression)
(fix:1+ (expression/size (declaration/expression expression)))))
-(define-method/size 'DELAY
+(define-method/size 'delay
(lambda (expression)
(fix:1+ (expression/size (delay/expression expression)))))
-(define-method/size 'DISJUNCTION
+(define-method/size 'disjunction
(lambda (expression)
(fix:+ (expression/size (disjunction/predicate expression))
(fix:1+ (expression/size (disjunction/alternative expression))))))
-(define-method/size 'OPEN-BLOCK
+(define-method/size 'open-block
(lambda (expression)
(fold-left (lambda (total action)
(if (eq? action open-block/value-marker)
1
(open-block/actions expression))))
-(define-method/size 'PROCEDURE
+(define-method/size 'procedure
(lambda (expression)
(fix:1+ (expression/size (procedure/body expression)))))
-(define-method/size 'QUOTATION
+(define-method/size 'quotation
(lambda (expression)
(fix:1+ (expression/size (quotation/expression expression)))))
-(define-method/size 'REFERENCE
+(define-method/size 'reference
(lambda (expression)
(declare (ignore expression))
1))
-(define-method/size 'SEQUENCE
+(define-method/size 'sequence
(lambda (expression)
(fold-left (lambda (total action)
(fix:+ total (expression/size action)))
(define define-method/expression->list
(expression/make-method-definer expression->list-dispatch-vector))
-(define-method/expression->list 'ACCESS
+(define-method/expression->list 'access
(lambda (expression)
- `(ACCESS ,(access/name expression)
+ `(access ,(access/name expression)
,(expression->list (access/environment expression)))))
-(define-method/expression->list 'ASSIGNMENT
+(define-method/expression->list 'assignment
(lambda (expression)
- `(SET! ,(assignment/variable expression)
+ `(set! ,(assignment/variable expression)
,(expression->list (assignment/value expression)))))
-(define-method/expression->list 'COMBINATION
+(define-method/expression->list 'combination
(lambda (expression)
(cons (expression->list (combination/operator expression))
(map expression->list (combination/operands expression)))))
-(define-method/expression->list 'CONDITIONAL
+(define-method/expression->list 'conditional
(lambda (expression)
- `(IF ,(expression->list (conditional/predicate expression))
+ `(if ,(expression->list (conditional/predicate expression))
,(expression->list (conditional/consequent expression))
,(expression->list (conditional/alternative expression)))))
-(define-method/expression->list 'CONSTANT
+(define-method/expression->list 'constant
(lambda (expression) (constant/value expression)))
-(define-method/expression->list 'DECLARATION
+(define-method/expression->list 'declaration
(lambda (expression)
- `(DECLARE ,(declaration/declarations expression)
+ `(declare ,(declaration/declarations expression)
,(expression->list (declaration/expression expression)))))
-(define-method/expression->list 'DELAY
+(define-method/expression->list 'delay
(lambda (expression)
- `(DELAY ,(expression->list (delay/expression expression)))))
+ `(delay ,(expression->list (delay/expression expression)))))
-(define-method/expression->list 'DISJUNCTION
+(define-method/expression->list 'disjunction
(lambda (expression)
- `(OR ,(expression->list (disjunction/predicate expression))
+ `(or ,(expression->list (disjunction/predicate expression))
,(expression->list (disjunction/alternative expression)))))
-(define-method/expression->list 'OPEN-BLOCK
+(define-method/expression->list 'open-block
(lambda (expression)
- `(OPEN-BLOCK
+ `(open-block
',(map variable/name (open-block/variables expression))
,@(map (lambda (action)
(if (eq? action open-block/value-marker)
- `(QUOTE ,action)
+ `(quote ,action)
(expression->list action)))
(open-block/actions expression)))))
-(define-method/expression->list 'PROCEDURE
+(define-method/expression->list 'procedure
(lambda (expression)
(let ((name (procedure/name expression))
(required (map variable/name (procedure/required expression)))
(rest (let ((rest-arg (procedure/rest expression)))
(and rest-arg
(variable/name rest-arg)))))
- `(PROCEDURE ,name
+ `(procedure ,name
,(make-lambda-list required optional rest '())
,(expression->list (procedure/body expression))))))
-(define-method/expression->list 'QUOTATION
+(define-method/expression->list 'quotation
(lambda (expression)
- `(QUOTE ,(quotation/expression expression))))
+ `(quote ,(quotation/expression expression))))
-(define-method/expression->list 'REFERENCE
+(define-method/expression->list 'reference
(lambda (expression)
(variable/name (reference/variable expression))))
-(define-method/expression->list 'SEQUENCE
+(define-method/expression->list 'sequence
(lambda (expression)
- `(BEGIN ,@(map expression->list (sequence/actions expression)))))
+ `(begin ,@(map expression->list (sequence/actions expression)))))
(define (directory-processor input-type output-type process-file)
(let ((directory-read
(let ((input-pattern
- (make-pathname #f #f #f 'WILD input-type 'NEWEST)))
+ (make-pathname #f #f #f 'wild input-type 'newest)))
(lambda (directory)
(directory-read
(merge-pathnames
;; Declarations which are not handled by SF but are known to be handled
;; by the compiler so SF ignores then silently.
'(
- CONSTANT
- IGNORE-ASSIGNMENT-TRAPS
- IGNORE-REFERENCE-TRAPS
- NO-RANGE-CHECKS
- NO-TYPE-CHECKS
- PURE-FUNCTION
- RANGE-CHECKS
- SIDE-EFFECT-FREE
- TYPE-CHECKS
- USUAL-DEFINITION
- UUO-LINK
+ constant
+ ignore-assignment-traps
+ ignore-reference-traps
+ no-range-checks
+ no-type-checks
+ pure-function
+ range-checks
+ side-effect-free
+ type-checks
+ usual-definition
+ uuo-link
))
(define (known-compiler-declaration? declaration)
(set-cdr! interns (cons association (cdr interns)))
association))))
\f
-(define-method/cgen 'ACCESS
+(define-method/cgen 'access
(lambda (interns expression)
(make-scode-access (cgen/expression interns (access/environment expression))
(access/name expression))))
-(define-method/cgen 'ASSIGNMENT
+(define-method/cgen 'assignment
(lambda (interns expression)
(make-scode-assignment
(scode-variable-name
(cgen/variable interns (assignment/variable expression)))
(cgen/expression interns (assignment/value expression)))))
-(define-method/cgen 'COMBINATION
+(define-method/cgen 'combination
(lambda (interns expression)
(make-scode-combination
(cgen/expression interns (combination/operator expression))
(cgen/expressions interns (combination/operands expression)))))
-(define-method/cgen 'CONDITIONAL
+(define-method/cgen 'conditional
(lambda (interns expression)
(make-scode-conditional
(cgen/expression interns (conditional/predicate expression))
(cgen/expression interns (conditional/consequent expression))
(cgen/expression interns (conditional/alternative expression)))))
-(define-method/cgen 'CONSTANT
+(define-method/cgen 'constant
(lambda (interns expression)
interns ; is ignored
(constant/value expression)))
-(define-method/cgen 'DECLARATION
+(define-method/cgen 'declaration
(lambda (interns expression)
(cgen/declaration (declaration/declarations expression)
(cgen/expression interns
(declaration/expression expression)))))
-(define-method/cgen 'DELAY
+(define-method/cgen 'delay
(lambda (interns expression)
(make-scode-delay (cgen/expression interns (delay/expression expression)))))
-(define-method/cgen 'DISJUNCTION
+(define-method/cgen 'disjunction
(lambda (interns expression)
(make-scode-disjunction
(cgen/expression interns (disjunction/predicate expression))
(cgen/expression interns (disjunction/alternative expression)))))
\f
-(define-method/cgen 'PROCEDURE
+(define-method/cgen 'procedure
(lambda (interns procedure)
interns ; ignored
(make-lambda* (procedure/name procedure)
(cons (cgen/expression (list block) (car actions))
(loop variables values (cdr actions))))))))))
-(define-method/cgen 'QUOTATION
+(define-method/cgen 'quotation
(lambda (interns expression)
interns ; ignored
(make-scode-quotation (cgen/top-level expression))))
-(define-method/cgen 'REFERENCE
+(define-method/cgen 'reference
(lambda (interns expression)
(cgen/variable interns (reference/variable expression))))
-(define-method/cgen 'SEQUENCE
+(define-method/cgen 'sequence
(lambda (interns expression)
(let ((actions
(if flush-declarations?
rest
(cons (car actions) rest)))))
-(define-method/cgen 'THE-ENVIRONMENT
+(define-method/cgen 'the-environment
(lambda (interns expression)
interns expression ; ignored
(make-scode-the-environment)))
(enumeration/name->enumerand enumeration
(enumerand/name (object/enumerand object)))))
-(define-method/change-type 'ACCESS
+(define-method/change-type 'access
(lambda (expression)
(change-type/expression (access/environment expression))))
-(define-method/change-type 'ASSIGNMENT
+(define-method/change-type 'assignment
(lambda (expression)
(change-type/expression (assignment/value expression))))
-(define-method/change-type 'COMBINATION
+(define-method/change-type 'combination
(lambda (expression)
(change-type/expression (combination/operator expression))
(change-type/expressions (combination/operands expression))))
-(define-method/change-type 'CONDITIONAL
+(define-method/change-type 'conditional
(lambda (expression)
(change-type/expression (conditional/predicate expression))
(change-type/expression (conditional/consequent expression))
(change-type/expression (conditional/alternative expression))))
-(define-method/change-type 'CONSTANT
+(define-method/change-type 'constant
false-procedure)
\f
-(define-method/change-type 'DECLARATION
+(define-method/change-type 'declaration
(lambda (expression)
(change-type/expression (declaration/expression expression))))
-(define-method/change-type 'DELAY
+(define-method/change-type 'delay
(lambda (expression)
(change-type/expression (delay/expression expression))))
-(define-method/change-type 'DISJUNCTION
+(define-method/change-type 'disjunction
(lambda (expression)
(change-type/expression (disjunction/predicate expression))
(change-type/expression (disjunction/alternative expression))))
-(define-method/change-type 'OPEN-BLOCK
+(define-method/change-type 'open-block
(lambda (expression)
(change-type/expressions (open-block/values expression))
(for-each (lambda (action)
(change-type/expression action)))
(open-block/actions expression))))
-(define-method/change-type 'PROCEDURE
+(define-method/change-type 'procedure
(lambda (expression)
(change-type/expression (procedure/body expression))))
-(define-method/change-type 'QUOTATION
+(define-method/change-type 'quotation
(lambda (expression)
(change-type/expression (quotation/expression expression))))
-(define-method/change-type 'REFERENCE
+(define-method/change-type 'reference
false-procedure)
-(define-method/change-type 'SEQUENCE
+(define-method/change-type 'sequence
(lambda (expression)
(change-type/expressions (sequence/actions expression))))
-(define-method/change-type 'THE-ENVIRONMENT
+(define-method/change-type 'the-environment
false-procedure)
\ No newline at end of file
(lambda (expression)
(copy/expression block environment expression)))))
\f
-(define-method/copy 'ACCESS
+(define-method/copy 'access
(lambda (block environment expression)
(call-with-values
(lambda ()
(access/environment expression))
(access/name expression))))))
-(define-method/copy 'ASSIGNMENT
+(define-method/copy 'assignment
(lambda (block environment expression)
(assignment/make
(assignment/scode expression)
(copy/variable block environment (assignment/variable expression))
(copy/expression block environment (assignment/value expression)))))
-(define-method/copy 'COMBINATION
+(define-method/copy 'combination
(lambda (block environment expression)
(combination/%make
(combination/scode expression)
(copy/expression block environment (combination/operator expression))
(copy/expressions block environment (combination/operands expression)))))
-(define-method/copy 'CONDITIONAL
+(define-method/copy 'conditional
(lambda (block environment expression)
(conditional/make
(conditional/scode expression)
(copy/expression block environment (conditional/consequent expression))
(copy/expression block environment (conditional/alternative expression)))))
-(define-method/copy 'CONSTANT
+(define-method/copy 'constant
(lambda (block environment expression)
(declare (ignore block environment))
expression))
-(define-method/copy 'DECLARATION
+(define-method/copy 'declaration
(lambda (block environment expression)
(declaration/make
(declaration/scode expression)
(declaration/declarations expression))
(copy/expression block environment (declaration/expression expression)))))
-(define-method/copy 'DELAY
+(define-method/copy 'delay
(lambda (block environment expression)
(delay/make
(delay/scode expression)
(copy/expression block environment (delay/expression expression)))))
-(define-method/copy 'DISJUNCTION
+(define-method/copy 'disjunction
(lambda (block environment expression)
(disjunction/make
(disjunction/scode expression)
environment
(disjunction/alternative expression)))))
\f
-(define-method/copy 'PROCEDURE
+(define-method/copy 'procedure
(lambda (block environment procedure)
(call-with-values
(lambda ()
environment
(procedure/body procedure))))))))
-(define-method/copy 'OPEN-BLOCK
+(define-method/copy 'open-block
(lambda (block environment expression)
(call-with-values
(lambda ()
(copy/expression block environment action)))
(open-block/actions expression)))))))
-(define-method/copy 'QUOTATION
+(define-method/copy 'quotation
(lambda (block environment expression)
(declare (ignore block environment))
(copy/quotation expression)))
-(define-method/copy 'REFERENCE
+(define-method/copy 'reference
(lambda (block environment expression)
(reference/make (reference/scode expression)
block
(copy/variable block environment
(reference/variable expression)))))
-(define-method/copy 'SEQUENCE
+(define-method/copy 'sequence
(lambda (block environment expression)
(sequence/make
(sequence/scode expression)
(copy/expressions block environment (sequence/actions expression)))))
-(define-method/copy 'THE-ENVIRONMENT
+(define-method/copy 'the-environment
(lambda (block environment expression)
(declare (ignore block environment expression))
(error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
\ No newline at end of file
(declare (usual-integrations))
\f
(define global-constant-objects
- '(CHAR-BITS-LIMIT
- CHAR-CODE-LIMIT
- FALSE
+ '(char-bits-limit
+ char-code-limit
+ false
scode-lambda-name:unnamed ;needed for cold load
- SYSTEM-GLOBAL-ENVIRONMENT ;suppresses warnings about (access ...)
- THE-EMPTY-STREAM
- TRUE
- UNDEFINED-SCODE-CONDITIONAL-BRANCH
- UNSPECIFIC))
+ system-global-environment ;suppresses warnings about (access ...)
+ the-empty-stream
+ true
+ undefined-scode-conditional-branch
+ unspecific))
(define global-primitives
'((%make-tagged-object %make-tagged-object 2)
- (%RECORD %RECORD)
- (%RECORD-LENGTH %RECORD-LENGTH)
- (%RECORD-REF %RECORD-REF)
- (%RECORD-SET! %RECORD-SET!)
- (%RECORD? %RECORD?)
+ (%record %record)
+ (%record-length %record-length)
+ (%record-ref %record-ref)
+ (%record-set! %record-set!)
+ (%record? %record?)
(%tagged-object-datum %tagged-object-datum 1)
(%tagged-object-tag %tagged-object-tag 1)
(%tagged-object? %tagged-object? 1)
(%weak-cons weak-cons 2)
(%weak-car weak-car 1)
(%weak-set-car! weak-set-car! 2)
- (BIT-STRING->UNSIGNED-INTEGER BIT-STRING->UNSIGNED-INTEGER)
- (BIT-STRING-ALLOCATE BIT-STRING-ALLOCATE)
- (BIT-STRING-AND! BIT-STRING-AND!)
- (BIT-STRING-ANDC! BIT-STRING-ANDC!)
- (BIT-STRING-CLEAR! BIT-STRING-CLEAR!)
- (BIT-STRING-FILL! BIT-STRING-FILL!)
- (BIT-STRING-LENGTH BIT-STRING-LENGTH)
- (BIT-STRING-MOVE! BIT-STRING-MOVE!)
- (BIT-STRING-MOVEC! BIT-STRING-MOVEC!)
- (BIT-STRING-OR! BIT-STRING-OR!)
- (BIT-STRING-REF BIT-STRING-REF)
- (BIT-STRING-SET! BIT-STRING-SET!)
- (BIT-STRING-XOR! BIT-STRING-XOR!)
- (BIT-STRING-ZERO? BIT-STRING-ZERO?)
- (BIT-STRING=? BIT-STRING=?)
- (BIT-STRING? BIT-STRING?)
- (BIT-SUBSTRING-FIND-NEXT-SET-BIT BIT-SUBSTRING-FIND-NEXT-SET-BIT)
- (BIT-SUBSTRING-MOVE-RIGHT! BIT-SUBSTRING-MOVE-RIGHT!)
- (BYTEVECTOR-LENGTH BYTEVECTOR-LENGTH 1)
- (BYTEVECTOR-U8-REF BYTEVECTOR-U8-REF 2)
- (BYTEVECTOR-U8-SET! BYTEVECTOR-U8-SET! 3)
- (BYTEVECTOR? BYTEVECTOR? 1)
- (CAR CAR)
- (CDR CDR)
- (CELL-CONTENTS CELL-CONTENTS)
- (CELL? CELL?)
- (CHAR->INTEGER CHAR->INTEGER)
- (CHAR? CHAR?)
- (COMPILED-CODE-ADDRESS->BLOCK COMPILED-CODE-ADDRESS->BLOCK)
- (COMPILED-CODE-ADDRESS->OFFSET COMPILED-CODE-ADDRESS->OFFSET)
- (CONS CONS)
- (EQ? EQ?)
- (ERROR-PROCEDURE ERROR-PROCEDURE)
- (EXACT-INTEGER? INTEGER?)
- (FALSE? NOT)
- (FIX:* MULTIPLY-FIXNUM)
- (FIX:+ PLUS-FIXNUM)
- (FIX:- MINUS-FIXNUM)
- (FIX:-1+ MINUS-ONE-PLUS-FIXNUM)
- (FIX:1+ ONE-PLUS-FIXNUM)
- (FIX:< LESS-THAN-FIXNUM?)
- (FIX:= EQUAL-FIXNUM?)
- (FIX:> GREATER-THAN-FIXNUM?)
- (FIX:AND FIXNUM-AND)
- (FIX:ANDC FIXNUM-ANDC)
- (FIX:DIVIDE DIVIDE-FIXNUM)
- (FIX:FIXNUM? FIXNUM?)
- (FIX:GCD GCD-FIXNUM)
- (FIX:LSH FIXNUM-LSH)
- (FIX:NEGATIVE? NEGATIVE-FIXNUM?)
- (FIX:NOT FIXNUM-NOT)
- (FIX:OR FIXNUM-OR)
- (FIX:POSITIVE? POSITIVE-FIXNUM?)
- (FIX:QUOTIENT FIXNUM-QUOTIENT)
- (FIX:REMAINDER FIXNUM-REMAINDER)
- (FIX:XOR FIXNUM-XOR)
- (FIX:ZERO? ZERO-FIXNUM?)
- (FIXNUM? FIXNUM?)
- (FLO:* FLONUM-MULTIPLY)
- (FLO:+ FLONUM-ADD)
- (FLO:- FLONUM-SUBTRACT)
- (FLO:/ FLONUM-DIVIDE)
- (FLO:< FLONUM-LESS?)
- (FLO:= FLONUM-EQUAL?)
- (FLO:> FLONUM-GREATER?)
- (FLO:ABS FLONUM-ABS)
- (FLO:ACOS FLONUM-ACOS)
- (FLO:ASIN FLONUM-ASIN)
- (FLO:ATAN FLONUM-ATAN)
- (FLO:ATAN2 FLONUM-ATAN2)
- (FLO:CEILING FLONUM-CEILING)
- (FLO:CEILING->EXACT FLONUM-CEILING->EXACT)
- (FLO:COS FLONUM-COS)
- (FLO:EXP FLONUM-EXP)
- (FLO:EXPM1 FLONUM-EXPM1)
- (FLO:EXPT FLONUM-EXPT)
- (FLO:FLONUM? FLONUM?)
- (FLO:FLOOR FLONUM-FLOOR)
- (FLO:FLOOR->EXACT FLONUM-FLOOR->EXACT)
- (FLO:LOG FLONUM-LOG)
- (FLO:LOG1P FLONUM-LOG1P)
- (FLO:NEGATE FLONUM-NEGATE)
- (FLO:NEGATIVE? FLONUM-NEGATIVE?)
- (FLO:POSITIVE? FLONUM-POSITIVE?)
- (FLO:ROUND FLONUM-ROUND)
- (FLO:ROUND->EXACT FLONUM-ROUND->EXACT)
- (FLO:SIN FLONUM-SIN)
- (FLO:SQRT FLONUM-SQRT)
- (FLO:TAN FLONUM-TAN)
- (FLO:TRUNCATE FLONUM-TRUNCATE)
- (FLO:TRUNCATE->EXACT FLONUM-TRUNCATE->EXACT)
- (FLO:VECTOR-CONS FLOATING-VECTOR-CONS)
- (FLO:VECTOR-LENGTH FLOATING-VECTOR-LENGTH)
- (FLO:VECTOR-REF FLOATING-VECTOR-REF)
- (FLO:VECTOR-SET! FLOATING-VECTOR-SET!)
- (FLO:ZERO? FLONUM-ZERO?)
- (GET-FIXED-OBJECTS-VECTOR GET-FIXED-OBJECTS-VECTOR)
- (GET-INTERRUPT-ENABLES GET-INTERRUPT-ENABLES)
- (HUNK3-CONS HUNK3-CONS)
- (INDEX-FIXNUM? INDEX-FIXNUM?)
- (INT:* INTEGER-MULTIPLY)
- (INT:+ INTEGER-ADD)
- (INT:- INTEGER-SUBTRACT)
- (INT:-1+ INTEGER-SUBTRACT-1)
- (INT:1+ INTEGER-ADD-1)
- (INT:< INTEGER-LESS?)
- (INT:= INTEGER-EQUAL?)
- (INT:> INTEGER-GREATER?)
- (INT:DIVIDE INTEGER-DIVIDE)
- (INT:INTEGER? INTEGER?)
- (INT:NEGATE INTEGER-NEGATE)
- (INT:NEGATIVE? INTEGER-NEGATIVE?)
- (INT:POSITIVE? INTEGER-POSITIVE?)
- (INT:QUOTIENT INTEGER-QUOTIENT)
- (INT:REMAINDER INTEGER-REMAINDER)
- (INT:ZERO? INTEGER-ZERO?)
- (INTEGER->CHAR INTEGER->CHAR)
- (LEXICAL-ASSIGNMENT LEXICAL-ASSIGNMENT)
- (LEXICAL-REFERENCE LEXICAL-REFERENCE)
- (LEXICAL-UNASSIGNED? LEXICAL-UNASSIGNED?)
- (LEXICAL-UNBOUND? LEXICAL-UNBOUND?)
- (LEXICAL-UNREFERENCEABLE? LEXICAL-UNREFERENCEABLE?)
- (LOCAL-ASSIGNMENT LOCAL-ASSIGNMENT)
- (MAKE-BIT-STRING MAKE-BIT-STRING)
- (MAKE-CELL MAKE-CELL)
- (MAKE-NON-POINTER-OBJECT MAKE-NON-POINTER-OBJECT)
- (NOT NOT)
- (NULL? NULL?)
- (OBJECT-DATUM OBJECT-DATUM)
- (OBJECT-NEW-TYPE OBJECT-SET-TYPE)
- (OBJECT-TYPE OBJECT-TYPE)
- (OBJECT-TYPE? OBJECT-TYPE?)
- (PAIR? PAIR?)
- (PRIMITIVE-PROCEDURE-ARITY PRIMITIVE-PROCEDURE-ARITY)
- (PRIMITIVE-PROCEDURE-DOCUMENTATION PRIMITIVE-PROCEDURE-DOCUMENTATION)
- (READ-BITS! READ-BITS!)
- (SET-CAR! SET-CAR!)
- (SET-CDR! SET-CDR!)
- (SET-CELL-CONTENTS! SET-CELL-CONTENTS!)
- (SET-INTERRUPT-ENABLES! SET-INTERRUPT-ENABLES!)
- (STACK-ADDRESS-OFFSET STACK-ADDRESS-OFFSET)
- (SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-CXR0)
- (SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-CXR1)
- (SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-CXR2)
- (SYSTEM-HUNK3-SET-CXR0! SYSTEM-HUNK3-SET-CXR0!)
- (SYSTEM-HUNK3-SET-CXR1! SYSTEM-HUNK3-SET-CXR1!)
- (SYSTEM-HUNK3-SET-CXR2! SYSTEM-HUNK3-SET-CXR2!)
- (SYSTEM-LIST->VECTOR SYSTEM-LIST-TO-VECTOR)
- (SYSTEM-PAIR-CAR SYSTEM-PAIR-CAR)
- (SYSTEM-PAIR-CDR SYSTEM-PAIR-CDR)
- (SYSTEM-PAIR-CONS SYSTEM-PAIR-CONS)
- (SYSTEM-PAIR-SET-CAR! SYSTEM-PAIR-SET-CAR!)
- (SYSTEM-PAIR-SET-CDR! SYSTEM-PAIR-SET-CDR!)
- (SYSTEM-PAIR? SYSTEM-PAIR?)
- (SYSTEM-SUBVECTOR->LIST SYSTEM-SUBVECTOR-TO-LIST)
- (SYSTEM-VECTOR-LENGTH SYSTEM-VECTOR-SIZE)
- (SYSTEM-VECTOR-REF SYSTEM-VECTOR-REF)
- (SYSTEM-VECTOR-SET! SYSTEM-VECTOR-SET!)
- (SYSTEM-VECTOR? SYSTEM-VECTOR?)
- (UNSIGNED-INTEGER->BIT-STRING UNSIGNED-INTEGER->BIT-STRING)
- (VECTOR VECTOR)
- (VECTOR-LENGTH VECTOR-LENGTH)
- (VECTOR-REF VECTOR-REF)
- (VECTOR-SET! VECTOR-SET!)
- (VECTOR? VECTOR?)
+ (bit-string->unsigned-integer bit-string->unsigned-integer)
+ (bit-string-allocate bit-string-allocate)
+ (bit-string-and! bit-string-and!)
+ (bit-string-andc! bit-string-andc!)
+ (bit-string-clear! bit-string-clear!)
+ (bit-string-fill! bit-string-fill!)
+ (bit-string-length bit-string-length)
+ (bit-string-move! bit-string-move!)
+ (bit-string-movec! bit-string-movec!)
+ (bit-string-or! bit-string-or!)
+ (bit-string-ref bit-string-ref)
+ (bit-string-set! bit-string-set!)
+ (bit-string-xor! bit-string-xor!)
+ (bit-string-zero? bit-string-zero?)
+ (bit-string=? bit-string=?)
+ (bit-string? bit-string?)
+ (bit-substring-find-next-set-bit bit-substring-find-next-set-bit)
+ (bit-substring-move-right! bit-substring-move-right!)
+ (bytevector-length bytevector-length 1)
+ (bytevector-u8-ref bytevector-u8-ref 2)
+ (bytevector-u8-set! bytevector-u8-set! 3)
+ (bytevector? bytevector? 1)
+ (car car)
+ (cdr cdr)
+ (cell-contents cell-contents)
+ (cell? cell?)
+ (char->integer char->integer)
+ (char? char?)
+ (compiled-code-address->block compiled-code-address->block)
+ (compiled-code-address->offset compiled-code-address->offset)
+ (cons cons)
+ (eq? eq?)
+ (error-procedure error-procedure)
+ (exact-integer? integer?)
+ (false? not)
+ (fix:* multiply-fixnum)
+ (fix:+ plus-fixnum)
+ (fix:- minus-fixnum)
+ (fix:-1+ minus-one-plus-fixnum)
+ (fix:1+ one-plus-fixnum)
+ (fix:< less-than-fixnum?)
+ (fix:= equal-fixnum?)
+ (fix:> greater-than-fixnum?)
+ (fix:and fixnum-and)
+ (fix:andc fixnum-andc)
+ (fix:divide divide-fixnum)
+ (fix:fixnum? fixnum?)
+ (fix:gcd gcd-fixnum)
+ (fix:lsh fixnum-lsh)
+ (fix:negative? negative-fixnum?)
+ (fix:not fixnum-not)
+ (fix:or fixnum-or)
+ (fix:positive? positive-fixnum?)
+ (fix:quotient fixnum-quotient)
+ (fix:remainder fixnum-remainder)
+ (fix:xor fixnum-xor)
+ (fix:zero? zero-fixnum?)
+ (fixnum? fixnum?)
+ (flo:* flonum-multiply)
+ (flo:+ flonum-add)
+ (flo:- flonum-subtract)
+ (flo:/ flonum-divide)
+ (flo:< flonum-less?)
+ (flo:= flonum-equal?)
+ (flo:> flonum-greater?)
+ (flo:abs flonum-abs)
+ (flo:acos flonum-acos)
+ (flo:asin flonum-asin)
+ (flo:atan flonum-atan)
+ (flo:atan2 flonum-atan2)
+ (flo:ceiling flonum-ceiling)
+ (flo:ceiling->exact flonum-ceiling->exact)
+ (flo:cos flonum-cos)
+ (flo:exp flonum-exp)
+ (flo:expm1 flonum-expm1)
+ (flo:expt flonum-expt)
+ (flo:flonum? flonum?)
+ (flo:floor flonum-floor)
+ (flo:floor->exact flonum-floor->exact)
+ (flo:log flonum-log)
+ (flo:log1p flonum-log1p)
+ (flo:negate flonum-negate)
+ (flo:negative? flonum-negative?)
+ (flo:positive? flonum-positive?)
+ (flo:round flonum-round)
+ (flo:round->exact flonum-round->exact)
+ (flo:sin flonum-sin)
+ (flo:sqrt flonum-sqrt)
+ (flo:tan flonum-tan)
+ (flo:truncate flonum-truncate)
+ (flo:truncate->exact flonum-truncate->exact)
+ (flo:vector-cons floating-vector-cons)
+ (flo:vector-length floating-vector-length)
+ (flo:vector-ref floating-vector-ref)
+ (flo:vector-set! floating-vector-set!)
+ (flo:zero? flonum-zero?)
+ (get-fixed-objects-vector get-fixed-objects-vector)
+ (get-interrupt-enables get-interrupt-enables)
+ (hunk3-cons hunk3-cons)
+ (index-fixnum? index-fixnum?)
+ (int:* integer-multiply)
+ (int:+ integer-add)
+ (int:- integer-subtract)
+ (int:-1+ integer-subtract-1)
+ (int:1+ integer-add-1)
+ (int:< integer-less?)
+ (int:= integer-equal?)
+ (int:> integer-greater?)
+ (int:divide integer-divide)
+ (int:integer? integer?)
+ (int:negate integer-negate)
+ (int:negative? integer-negative?)
+ (int:positive? integer-positive?)
+ (int:quotient integer-quotient)
+ (int:remainder integer-remainder)
+ (int:zero? integer-zero?)
+ (integer->char integer->char)
+ (lexical-assignment lexical-assignment)
+ (lexical-reference lexical-reference)
+ (lexical-unassigned? lexical-unassigned?)
+ (lexical-unbound? lexical-unbound?)
+ (lexical-unreferenceable? lexical-unreferenceable?)
+ (local-assignment local-assignment)
+ (make-bit-string make-bit-string)
+ (make-cell make-cell)
+ (make-non-pointer-object make-non-pointer-object)
+ (not not)
+ (null? null?)
+ (object-datum object-datum)
+ (object-new-type object-set-type)
+ (object-type object-type)
+ (object-type? object-type?)
+ (pair? pair?)
+ (primitive-procedure-arity primitive-procedure-arity)
+ (primitive-procedure-documentation primitive-procedure-documentation)
+ (read-bits! read-bits!)
+ (set-car! set-car!)
+ (set-cdr! set-cdr!)
+ (set-cell-contents! set-cell-contents!)
+ (set-interrupt-enables! set-interrupt-enables!)
+ (stack-address-offset stack-address-offset)
+ (system-hunk3-cxr0 system-hunk3-cxr0)
+ (system-hunk3-cxr1 system-hunk3-cxr1)
+ (system-hunk3-cxr2 system-hunk3-cxr2)
+ (system-hunk3-set-cxr0! system-hunk3-set-cxr0!)
+ (system-hunk3-set-cxr1! system-hunk3-set-cxr1!)
+ (system-hunk3-set-cxr2! system-hunk3-set-cxr2!)
+ (system-list->vector system-list-to-vector)
+ (system-pair-car system-pair-car)
+ (system-pair-cdr system-pair-cdr)
+ (system-pair-cons system-pair-cons)
+ (system-pair-set-car! system-pair-set-car!)
+ (system-pair-set-cdr! system-pair-set-cdr!)
+ (system-pair? system-pair?)
+ (system-subvector->list system-subvector-to-list)
+ (system-vector-length system-vector-size)
+ (system-vector-ref system-vector-ref)
+ (system-vector-set! system-vector-set!)
+ (system-vector? system-vector?)
+ (unsigned-integer->bit-string unsigned-integer->bit-string)
+ (vector vector)
+ (vector-length vector-length)
+ (vector-ref vector-ref)
+ (vector-set! vector-set!)
+ (vector? vector?)
(weak-cdr weak-cdr 1)
(weak-pair? weak-pair? 1)
(weak-pair/car? weak-car 1)
(weak-set-cdr! weak-set-cdr! 2)
- (WITH-HISTORY-DISABLED WITH-HISTORY-DISABLED)
- (WITH-INTERRUPT-MASK WITH-INTERRUPT-MASK)
- (WRITE-BITS! WRITE-BITS!)))
\ No newline at end of file
+ (with-history-disabled with-history-disabled)
+ (with-interrupt-mask with-interrupt-mask)
+ (write-bits! write-bits!)))
\ No newline at end of file
(lambda (form environment)
(let ((enumeration-name (cadr form))
(enumerand-names (caddr form)))
- `(BEGIN
- (DEFINE ,enumeration-name
- (ENUMERATION/MAKE ',enumerand-names))
+ `(begin
+ (define ,enumeration-name
+ (enumeration/make ',enumerand-names))
,@(map (lambda (enumerand-name)
- `(DEFINE ,(symbol enumerand-name '/ENUMERAND)
- (ENUMERATION/NAME->ENUMERAND
+ `(define ,(symbol enumerand-name '/enumerand)
+ (enumeration/name->enumerand
,(close-syntax enumeration-name environment)
',enumerand-name)))
enumerand-names))))))
(let ((name (second form))
(constructor-name (third form)) ;; symbol or #F
(slots (fourth form)))
- `(BEGIN
- (DEFINE-STRUCTURE
+ `(begin
+ (define-structure
(,name
- (TYPE VECTOR)
- (NAMED
- ,(close-syntax (symbol name '/ENUMERAND) environment))
- (TYPE-DESCRIPTOR ,(symbol 'RTD: name))
- (CONC-NAME ,(symbol name '/))
- (CONSTRUCTOR ,(or constructor-name
- (symbol name '/MAKE))))
+ (type vector)
+ (named
+ ,(close-syntax (symbol name '/enumerand) environment))
+ (type-descriptor ,(symbol 'rtd: name))
+ (conc-name ,(symbol name '/))
+ (constructor ,(or constructor-name
+ (symbol name '/make))))
(scode #f read-only #t)
,@slots)
- (DEFINE-GUARANTEE ,name ,(symbol->string name)))))))
+ (define-guarantee ,name ,(symbol->string name)))))))
;;; These accessors apply to all the record types.
(define-integrable (object/enumerand object)
(named delayed-integration/enumerand)
(conc-name delayed-integration/)
(constructor delayed-integration/make (operations value)))
- (state 'NOT-INTEGRATED)
+ (state 'not-integrated)
(environment #f)
operations
value)
(map (lambda (name)
(make-primitive-procedure name #t))
'(
- %RECORD?
+ %record?
&<
&=
&>
- BIT-STRING?
- CELL?
- CHAR?
- EQ?
- EQUAL-FIXNUM?
- FIXNUM?
- FLONUM-EQUAL?
- FLONUM-GREATER?
- FLONUM-LESS?
- FLONUM-NEGATIVE?
- FLONUM-POSITIVE?
- FLONUM-ZERO?
- FLONUM?
- GREATER-THAN-FIXNUM?
- INDEX-FIXNUM?
- INTEGER-EQUAL?
- INTEGER-GREATER?
- INTEGER-LESS?
- INTEGER-NEGATIVE?
- INTEGER-POSITIVE?
- INTEGER-ZERO?
- LESS-THAN-FIXNUM?
- NEGATIVE-FIXNUM?
- NEGATIVE?
- NOT
- NULL?
- OBJECT-TYPE?
- PAIR?
- POSITIVE-FIXNUM?
- POSITIVE?
- STRING?
- VECTOR?
- ZERO-FIXNUM?
- ZERO?
+ bit-string?
+ cell?
+ char?
+ eq?
+ equal-fixnum?
+ fixnum?
+ flonum-equal?
+ flonum-greater?
+ flonum-less?
+ flonum-negative?
+ flonum-positive?
+ flonum-zero?
+ flonum?
+ greater-than-fixnum?
+ index-fixnum?
+ integer-equal?
+ integer-greater?
+ integer-less?
+ integer-negative?
+ integer-positive?
+ integer-zero?
+ less-than-fixnum?
+ negative-fixnum?
+ negative?
+ not
+ null?
+ object-type?
+ pair?
+ positive-fixnum?
+ positive?
+ string?
+ vector?
+ zero-fixnum?
+ zero?
)))
;; True if expression is a call to one of the primitive-boolean-predicates.
(map (lambda (name)
(make-primitive-procedure name #t))
'(
- %RECORD?
- BIT-STRING?
- CELL?
- CHAR?
- EQ?
- FIXNUM?
- FLONUM?
- NOT
- NULL?
- OBJECT-TYPE
- OBJECT-TYPE?
- PAIR?
- STRING?
- VECTOR?
+ %record?
+ bit-string?
+ cell?
+ char?
+ eq?
+ fixnum?
+ flonum?
+ not
+ null?
+ object-type
+ object-type?
+ pair?
+ string?
+ vector?
)))
;; True if expression is a call to one of the effect-free-primitives.
&/
-1+
1+
- CELL?
- CHAR->INTEGER
- CHAR-BITS
- CHAR-CODE
- CHAR-DOWNCASE
- CHAR-UPCASE
- COMPILED-CODE-ADDRESS->BLOCK
- COMPILED-CODE-ADDRESS->OFFSET
- DIVIDE-FIXNUM
- EQ?
- EQUAL-FIXNUM?
- FIXNUM-AND
- FIXNUM-ANDC
- FIXNUM-LSH
- FIXNUM-NOT
- FIXNUM-OR
- FIXNUM-QUOTIENT
- FIXNUM-REMAINDER
- FIXNUM-XOR
- FLONUM-ABS
- FLONUM-ACOS
- FLONUM-ADD
- FLONUM-ASIN
- FLONUM-ATAN
- FLONUM-ATAN2
- FLONUM-CEILING
- FLONUM-CEILING->EXACT
- FLONUM-COS
- FLONUM-DIVIDE
- FLONUM-EQUAL?
- FLONUM-EXP
- FLONUM-EXPT
- FLONUM-FLOOR
- FLONUM-FLOOR->EXACT
- FLONUM-GREATER?
- FLONUM-LESS?
- FLONUM-LOG
- FLONUM-MULTIPLY
- FLONUM-NEGATE
- FLONUM-NEGATIVE?
- FLONUM-POSITIVE?
- FLONUM-ROUND
- FLONUM-ROUND->EXACT
- FLONUM-SIN
- FLONUM-SQRT
- FLONUM-SUBTRACT
- FLONUM-TAN
- FLONUM-TRUNCATE
- FLONUM-TRUNCATE->EXACT
- FLONUM-ZERO?
- GCD-FIXNUM
- GREATER-THAN-FIXNUM?
- INDEX-FIXNUM?
- INTEGER->CHAR
- LESS-THAN-FIXNUM?
- MAKE-CHAR
- MAKE-NON-POINTER-OBJECT
- MINUS-FIXNUM
- MINUS-ONE-PLUS-FIXNUM
- MULTIPLY-FIXNUM
- NEGATIVE-FIXNUM?
- NEGATIVE?
- NOT
- NULL?
- OBJECT-TYPE
- OBJECT-TYPE?
- ONE-PLUS-FIXNUM
- PAIR?
- PLUS-FIXNUM
- POSITIVE-FIXNUM?
- POSITIVE?
- PRIMITIVE-PROCEDURE-ARITY
+ cell?
+ char->integer
+ char-bits
+ char-code
+ char-downcase
+ char-upcase
+ compiled-code-address->block
+ compiled-code-address->offset
+ divide-fixnum
+ eq?
+ equal-fixnum?
+ fixnum-and
+ fixnum-andc
+ fixnum-lsh
+ fixnum-not
+ fixnum-or
+ fixnum-quotient
+ fixnum-remainder
+ fixnum-xor
+ flonum-abs
+ flonum-acos
+ flonum-add
+ flonum-asin
+ flonum-atan
+ flonum-atan2
+ flonum-ceiling
+ flonum-ceiling->exact
+ flonum-cos
+ flonum-divide
+ flonum-equal?
+ flonum-exp
+ flonum-expt
+ flonum-floor
+ flonum-floor->exact
+ flonum-greater?
+ flonum-less?
+ flonum-log
+ flonum-multiply
+ flonum-negate
+ flonum-negative?
+ flonum-positive?
+ flonum-round
+ flonum-round->exact
+ flonum-sin
+ flonum-sqrt
+ flonum-subtract
+ flonum-tan
+ flonum-truncate
+ flonum-truncate->exact
+ flonum-zero?
+ gcd-fixnum
+ greater-than-fixnum?
+ index-fixnum?
+ integer->char
+ less-than-fixnum?
+ make-char
+ make-non-pointer-object
+ minus-fixnum
+ minus-one-plus-fixnum
+ multiply-fixnum
+ negative-fixnum?
+ negative?
+ not
+ null?
+ object-type
+ object-type?
+ one-plus-fixnum
+ pair?
+ plus-fixnum
+ positive-fixnum?
+ positive?
+ primitive-procedure-arity
;; STRING->SYMBOL is a special case. Strings can
;; be side-effected, but it is useful to be able to
;; constant fold this primitive anyway.
- STRING->SYMBOL
- STRING-LENGTH
- ZERO-FIXNUM?
- ZERO?
+ string->symbol
+ string-length
+ zero-fixnum?
+ zero?
)))
(define (foldable-combination? operator operands)
(let ((name (cadr form))
(tester (caddr form))
(setter (cadddr form)))
- `(BEGIN
- (DEFINE (,tester VARIABLE)
- (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (DEFINE (,setter VARIABLE)
- (IF (NOT (MEMQ ',name (VARIABLE/FLAGS VARIABLE)))
- (SET-VARIABLE/FLAGS!
- VARIABLE
- (CONS ',name (VARIABLE/FLAGS VARIABLE))))))))))
-
-(define-flag SIDE-EFFECTED variable/side-effected variable/side-effect!)
-(define-flag REFERENCED variable/referenced variable/reference!)
-(define-flag INTEGRATED variable/integrated variable/integrated!)
-(define-flag MAY-IGNORE variable/may-ignore? variable/may-ignore!)
-(define-flag MUST-IGNORE variable/must-ignore? variable/must-ignore!)
+ `(begin
+ (define (,tester variable)
+ (memq ',name (variable/flags variable)))
+ (define (,setter variable)
+ (if (not (memq ',name (variable/flags variable)))
+ (set-variable/flags!
+ variable
+ (cons ',name (variable/flags variable))))))))))
+
+(define-flag side-effected variable/side-effected variable/side-effect!)
+(define-flag referenced variable/referenced variable/reference!)
+(define-flag integrated variable/integrated variable/integrated!)
+(define-flag may-ignore variable/may-ignore? variable/may-ignore!)
+(define-flag must-ignore variable/must-ignore? variable/must-ignore!)
(define open-block/value-marker
;; This must be an interned object because we will fasdump it and
declarations))))
(define (merge-usual-integrations declarations)
- (let loop ((declarations declarations) (exclusions 'NONE) (other '()))
+ (let loop ((declarations declarations) (exclusions 'none) (other '()))
(if (pair? declarations)
- (if (eq? (caar declarations) 'USUAL-INTEGRATIONS)
+ (if (eq? (caar declarations) 'usual-integrations)
(loop (cdr declarations)
- (if (eq? exclusions 'NONE)
+ (if (eq? exclusions 'none)
(cdar declarations)
(append exclusions (cdar declarations)))
other)
(loop (cdr declarations)
exclusions
(cons (car declarations) other)))
- (if (eq? exclusions 'NONE)
+ (if (eq? exclusions 'none)
(reverse! other)
- (cons `(USUAL-INTEGRATIONS ,@exclusions)
+ (cons `(usual-integrations ,@exclusions)
(reverse! other))))))
(define (declarations/make-null)
operations
(loop (let ((declaration (car declarations)))
((case (declaration/binding-level declaration)
- ((LOCAL) operations/bind)
- ((TOP-LEVEL) operations/bind-top-level)
- ((GLOBAL) operations/bind-global)
+ ((local) operations/bind)
+ ((top-level) operations/bind-top-level)
+ ((global) operations/bind-global)
(else
(error "Unrecognized binding level"
(declaration/binding-level declaration))))
(binding-level #f read-only #t))
(define (make-declarations operation variables values binding-level)
- (if (eq? values 'NO-VALUES)
+ (if (eq? values 'no-values)
(map (lambda (variable)
(make-declaration operation variable #f binding-level))
variables)
'())
(define (known-declaration? operation)
- (or (eq? operation 'EXPAND) ; this one is special
+ (or (eq? operation 'expand) ; this one is special
(assq operation known-declarations)))
\f
;;;; Integration Declarations
-(define-declaration 'USUAL-INTEGRATIONS
+(define-declaration 'usual-integrations
;; This is written in a strange way because the obvious way to write
;; it is quadratic in the number of names being declared. Since
;; there are typically over 300 names, this matters some. I believe
(cons (make-declaration operation
variable
value
- 'GLOBAL)
+ 'global)
declarations))
(set! remaining
(cons (vector operation name value)
(receive (expansion-names expansion-values)
(do-deletions usual-integrations/expansion-names
usual-integrations/expansion-values)
- (for-each (constructor 'EXPAND)
+ (for-each (constructor 'expand)
expansion-names
expansion-values))
(receive (constant-names constant-values)
(do-deletions usual-integrations/constant-names
usual-integrations/constant-values)
- (for-each (constructor 'INTEGRATE)
+ (for-each (constructor 'integrate)
constant-names
constant-values)))
(map* declarations
(vector-ref remaining 0)
(variable/make&bind! top-level-block (vector-ref remaining 1))
(vector-ref remaining 2)
- 'GLOBAL)))
+ 'global)))
remaining))))
\f
(define (define-integration-declaration operation)
(lambda (block names)
(make-declarations operation
(block/lookup-names block names #t)
- 'NO-VALUES
- 'LOCAL))))
+ 'no-values
+ 'local))))
-(define-integration-declaration 'INTEGRATE)
-(define-integration-declaration 'INTEGRATE-OPERATOR)
+(define-integration-declaration 'integrate)
+(define-integration-declaration 'integrate-operator)
-(define-declaration 'INTEGRATE-EXTERNAL
+(define-declaration 'integrate-external
(lambda (block specifications)
(append-map
(lambda (pathname)
(let ((operation (vector-ref extern 0))
(name (vector-ref extern 1))
(value (vector-ref extern 2)))
- (if (and (eq? 'EXPAND operation)
+ (if (and (eq? 'expand operation)
(dumped-expander? value))
(parse-declaration block
(dumped-expander/declaration value))
name)
(make-integration-info
(copy/expression/extern block value))
- 'TOP-LEVEL))))))
+ 'top-level))))))
externs))))
(append-map (lambda (specification)
(let ((value
;; IGNORABLE suppresses warnings about the variable not being used.
;; This is useful in macros that bind variables that the body may
;; not actually use.
-(define-declaration 'IGNORABLE
+(define-declaration 'ignorable
(lambda (block names)
(for-each (lambda (name)
(let ((variable (block/lookup-name block name #f)))
;; IGNORE causes warnings if an ignored variable actually ends
;; up being used. Mentioning the variable in a sequence will
;; have the effect of marking it IGNORED.
-(define-declaration 'IGNORE
+(define-declaration 'ignore
(lambda (block names)
(let ((variables
(let loop
name)
(loop (cdr names) variables))))
variables))))
- (make-declarations 'IGNORE
+ (make-declarations 'ignore
variables
- 'NO-VALUES
- 'LOCAL))))
+ 'no-values
+ 'local))))
\f
;;;; Reductions and Expansions
;;; See "reduct.scm" for description of REDUCE-OPERATOR and REPLACE-OPERATOR.
-(define-declaration 'REDUCE-OPERATOR
+(define-declaration 'reduce-operator
(lambda (block reduction-rules)
- (check-declaration-syntax 'REDUCE-OPERATOR reduction-rules)
+ (check-declaration-syntax 'reduce-operator reduction-rules)
(map (lambda (rule)
- (make-declaration 'EXPAND
+ (make-declaration 'expand
(block/lookup-name block (car rule) #t)
(make-dumpable-expander (reducer/make rule block)
- `(REDUCE-OPERATOR ,rule))
- 'LOCAL))
+ `(reduce-operator ,rule))
+ 'local))
reduction-rules)))
(define (check-declaration-syntax kind declarations)
declarations)))
(error "Bad declaration:" kind declarations)))
-(define-declaration 'REPLACE-OPERATOR
+(define-declaration 'replace-operator
(lambda (block replacements)
(if (not (and (list? replacements)
(every (lambda (replacement)
(and (pair? replacement)
(or (symbol? (car replacement))
(and (pair? (car replacement))
- (eq? 'PRIMITIVE (caar replacement))
+ (eq? 'primitive (caar replacement))
(pair? (cdar replacement))
(symbol? (cadar replacement))
(or (null? (cddar replacement))
(cdddar replacement))))))
(list? (cdr replacement))))
replacements)))
- (error "Bad declaration:" 'REPLACE-OPERATOR replacements))
+ (error "Bad declaration:" 'replace-operator replacements))
(map (lambda (replacement)
(make-declaration
- 'EXPAND
+ 'expand
(let ((name (car replacement)))
(cond ((symbol? name)
(block/lookup-name block name #t))
((and (pair? name)
- (eq? (car name) 'PRIMITIVE))
+ (eq? (car name) 'primitive))
(make-primitive-procedure (cadr name)
(and (not (null? (cddr name)))
(caddr name))))
(error "Illegal name in replacement:" name))))
(make-dumpable-expander
(replacement/make replacement block)
- `(REPLACE-OPERATOR ,replacement))
- 'LOCAL))
+ `(replace-operator ,replacement))
+ 'local))
replacements)))
\f
(define (make-dumpable-expander expander declaration)
(make-entity (lambda (self expr operands block)
self ; ignored
(expander expr operands block))
- (cons '*DUMPABLE-EXPANDER* declaration)))
+ (cons '*dumpable-expander* declaration)))
(define (dumpable-expander? object)
(and (entity? object)
(let ((extra (entity-extra object)))
(and (pair? extra)
- (eq? '*DUMPABLE-EXPANDER* (car extra))))))
+ (eq? '*dumpable-expander* (car extra))))))
(define (dumpable-expander->dumped-expander expander)
(cons dumped-expander-tag (cdr (entity-extra expander))))
;;; knowing a fair amount about the internals of sf. This declaration
;;; is purely a hook, with no convenience.
-(define-declaration 'EXPAND-OPERATOR
+(define-declaration 'expand-operator
(lambda (block expanders)
(map (lambda (expander)
- (make-declaration 'EXPAND
+ (make-declaration 'expand
(block/lookup-name block (car expander) #t)
(eval (cadr expander)
expander-evaluation-environment)
- 'LOCAL))
+ 'local))
expanders)))
\ No newline at end of file
(variable/make block exp '()))
((not (pair? exp))
(constant exp))
- ((eq? (car exp) 'PRIMITIVE)
+ ((eq? (car exp) 'primitive)
(cond ((or (null? (cdr exp)) (not (list? exp)))
(fail))
((null? (cddr exp))
(make-primitive-procedure (cadr exp) (caddr exp))))
(else
(fail))))
- ((eq? (car exp) 'QUOTE)
+ ((eq? (car exp) 'quote)
(if (or (not (pair? (cdr exp)))
(not (null? (cddr exp))))
(fail))
(constant (cadr exp)))
- ((eq? (car exp) 'GLOBAL)
+ ((eq? (car exp) 'global)
(if (or (not (pair? (cdr exp)))
(not (null? (cddr exp)))
(not (symbol? (cadr exp))))
map1 map2
binop source-block exprs
wrap last single none)
- (let ((expr (->expression 'REDUCE-OPERATOR binop source-block)))
+ (let ((expr (->expression 'reduce-operator binop source-block)))
(let ((vars (filter-vars (cons expr exprs)))
(binop (map1
(handle-variable
(define (check opts)
;; options is guaranteed to be a list. No need to check for pairness.
(cond ((null? opts)
- 'DONE)
+ 'done)
((or (not (pair? (car opts)))
(not (list? (car opts))))
(error "DECODE-OPTIONS: Bad option" (car opts)))
(cond ((not wrapper)
(receiver 0 identity-wrapper '()))
((null? (cdr wrapper))
- (let ((expr (->expression 'REDUCE-OPERATOR (car wrapper) block)))
+ (let ((expr (->expression 'reduce-operator (car wrapper) block)))
(receiver 0 (->wrapper expr) (list expr))))
((and (null? (cddr wrapper))
(exact-nonnegative-integer? (cadr wrapper)))
- (let ((expr (->expression 'REDUCE-OPERATOR (car wrapper) block)))
+ (let ((expr (->expression 'reduce-operator (car wrapper) block)))
(receiver (cadr wrapper) (->wrapper expr) (list expr))))
(else
- (fail 'WRAPPER wrapper))))
+ (fail 'wrapper wrapper))))
(define (with-singleton singleton block receiver)
(cond ((not singleton)
(receiver identity-combiner '()))
((null? (cdr singleton))
- (let ((expr (->expression 'REDUCE-OPERATOR (car singleton) block)))
+ (let ((expr (->expression 'reduce-operator (car singleton) block)))
(receiver (->mapper-combiner expr)
(list expr))))
(else
- (fail 'SINGLETON singleton))))
+ (fail 'singleton singleton))))
\f
;;;; Reduction top level
(define (reducer/make rule block)
(with-arguments-from rule
(lambda (name binop . options)
- (decode-options '(NULL-VALUE GROUP SINGLETON WRAPPER MAXIMUM)
+ (decode-options '(null-value group singleton wrapper maximum)
options
(lambda (null-value group singleton wrapper maximum)
(if (or (not (null? (cdr maximum)))
(not (exact-nonnegative-integer?
(car maximum))))
- (fail 'MAXIMUM maximum)
+ (fail 'maximum maximum)
(car maximum)))))
(grouper spare-args min-args max-args
binop block
'() single-combiner
single-combiner (->error-thunk name)))
((not (= (length null-value) 2))
- (fail 'NULL-VALUE null-value))
+ (fail 'null-value null-value))
(else
- (let* ((val (->expression 'REDUCE-OPERATOR
+ (let* ((val (->expression 'reduce-operator
(car null-value)
block))
(combiner (->singleton-combiner val))
(null (->value-thunk val)))
(case (cadr null-value)
- ((ANY ALWAYS)
+ ((any always)
(if singleton
- (incompatible 'SINGLETON singleton
- 'NULL-VALUE null-value))
+ (incompatible 'singleton singleton
+ 'null-value null-value))
(invoke spare-args (list val) combiner
combiner null))
- ((ONE SINGLE)
+ ((one single)
(if singleton
- (incompatible 'SINGLETON singleton
- 'NULL-VALUE null-value))
+ (incompatible 'singleton singleton
+ 'null-value null-value))
(invoke (1+ spare-args) (list val)
identity-combiner
combiner null))
- ((NONE EMPTY)
+ ((none empty)
(invoke spare-args
(list val) single-combiner
single-combiner null))
(else
- (fail 'NULL-VALUE null-value)))))))))))
+ (fail 'null-value null-value)))))))))))
(cond ((not group)
(make-reducer-internal group-right))
((not (null? (cdr group)))
- (fail 'GROUP group))
+ (fail 'group group))
(else
(case (car group)
- ((RIGHT ASSOCIATIVE)
+ ((right associative)
(make-reducer-internal group-right))
- ((LEFT)
+ ((left)
(make-reducer-internal group-left))
(else
- (fail 'GROUP group))))))))))
+ (fail 'group group))))))))))
\f
;;;; Replacement top level
(define (expr->case expr)
(cons (and (symbol? expr) expr)
- (->expression 'REPLACE-OPERATOR
+ (->expression 'replace-operator
expr
block)))
parsed)
(max (1+ len*) len)
default)))
- ((memq (car a-case) '(ANY ELSE OTHERWISE))
+ ((memq (car a-case) '(any else otherwise))
(if default
(error "REPLACE-OPERATOR: Duplicate default" ocases))
(parse (cdr cases)
(define define-method/integrate
(expression/make-method-definer dispatch-vector))
\f
-;;;; ACCESS
-(define-method/integrate 'ACCESS
+(define-method/integrate 'access
(lambda (operations environment expression)
(let ((environment* (integrate/expression operations environment
(access/environment expression)))
operations name
(lambda (operation info)
(case operation
- ((#F EXPAND) (dont-integrate))
+ ((#f expand) (dont-integrate))
- ((IGNORE)
+ ((ignore)
(ignored-variable-warning name)
(dont-integrate))
- ((INTEGRATE)
+ ((integrate)
(reassign name (copy/expression/intern
(access/block expression)
(integration-info/expression info))))
- ((INTEGRATE-OPERATOR)
+ ((integrate-operator)
(warn "Not integrating operator in access: " name)
(dont-integrate))
(error "Unknown operation" operation))))
dont-integrate)))))
-;;;; ASSIGNMENT
-(define-method/integrate 'ASSIGNMENT
+(define-method/integrate 'assignment
(lambda (operations environment assignment)
(let ((variable (assignment/variable assignment)))
(operations/lookup operations variable
(lambda (operation info)
info ;ignore
(case operation
- ((IGNORE)
+ ((ignore)
(ignored-variable-warning (variable/name variable)))
- ((EXPAND INTEGRATE INTEGRATE-OPERATOR)
+ ((expand integrate integrate-operator)
(warn "Attempt to assign integrated name"
(variable/name variable)))
(else (error "Unknown operation" operation))))
environment
(assignment/value assignment))))))
-;;;; COMBINATION
-(define-method/integrate 'COMBINATION
+(define-method/integrate 'combination
(lambda (operations environment combination)
(integrate/combination
combination operations environment
(integrate/expressions operations
environment
(combination/operands combination)))))
-
-;;;; CONDITIONAL
-(define-method/integrate 'CONDITIONAL
+\f
+(define-method/integrate 'conditional
(lambda (operations environment expression)
(integrate/conditional operations environment expression
(integrate/expression
(integrate/expression operations environment alternative))))
(else
- (conditional/make (and expression (conditional/scode expression))
- integrated-predicate
- (integrate/expression operations environment consequent)
- (integrate/expression operations environment alternative)))))
+ (conditional/make
+ (and expression (conditional/scode expression))
+ integrated-predicate
+ (integrate/expression operations environment consequent)
+ (integrate/expression operations environment alternative)))))
-;;; CONSTANT
-(define-method/integrate 'CONSTANT
+(define-method/integrate 'constant
(lambda (operations environment expression)
(declare (ignore operations environment))
expression))
-;;; DECLARATION
-(define-method/integrate 'DECLARATION
+(define-method/integrate 'declaration
(lambda (operations environment declaration)
(let ((answer
(integrate/expression
(declaration/declarations declaration)
answer)))))
-;;; DELAY
-(define-method/integrate 'DELAY
+(define-method/integrate 'delay
(lambda (operations environment expression)
(delay/make
(delay/scode expression)
(integrate/expression operations environment
(delay/expression expression)))))
-
-
-;;; DISJUNCTION
-(define-method/integrate 'DISJUNCTION
+\f
+(define-method/integrate 'disjunction
(lambda (operations environment expression)
(integrate/disjunction
operations environment expression
environment alternative)))))
;;; OPEN-BLOCK
-(define-method/integrate 'OPEN-BLOCK
+(define-method/integrate 'open-block
(lambda (operations environment expression)
(call-with-values
(lambda () (integrate/open-block operations environment expression))
(declare (ignore operations environment))
expression))))
-;;; PROCEDURE
-(define-method/integrate 'PROCEDURE
+(define-method/integrate 'procedure
(lambda (operations environment procedure)
(integrate/procedure operations
(simulate-unknown-application environment procedure)
procedure)))
-;;;; Quotation
-(define-method/integrate 'QUOTATION
+(define-method/integrate 'quotation
(lambda (operations environment expression)
(declare (ignore operations environment))
(integrate/quotation expression)))
(lambda (operations environment expression)
operations environment ;ignore
expression)))
-
-;;;; Reference
+\f
(define sf:warn-on-unintegrated-argument #f)
-(define-method/integrate 'REFERENCE
+(define-method/integrate 'reference
(lambda (operations environment expression)
(let ((variable (reference/variable expression)))
(define (dont-integrate)
operations variable
(lambda (operation info)
(case operation
- ((IGNORE)
+ ((ignore)
(ignored-variable-warning (variable/name variable))
(dont-integrate))
- ((EXPAND)
+ ((expand)
(dont-integrate))
- ((INTEGRATE)
+ ((integrate)
(let ((new-expression
(integrate/name expression expression info environment)))
(if new-expression
new-expression)
(dont-integrate))))
- ((INTEGRATE-OPERATOR)
+ ((integrate-operator)
(if sf:warn-on-unintegrated-argument
- (warn "Not integrating operator in argument position: " variable))
+ (warn "Not integrating operator in argument position: "
+ variable))
(dont-integrate))
(else
(with-new-scode (object/scode expr) object)
object))
-;;; SEQUENCE
-(define-method/integrate 'SEQUENCE
+(define-method/integrate 'sequence
(lambda (operations environment expression)
(sequence/make
(and expression (object/scode expression))
(integrate/actions operations environment
(sequence/actions expression)))))
-;;; THE-ENVIRONMENT
-(define-method/integrate 'THE-ENVIRONMENT
+(define-method/integrate 'the-environment
(lambda (operations environment expression)
operations
environment
(not (variable/referenced variable))
(not (variable/may-ignore? variable))
(not (variable/must-ignore? variable))))
-
+\f
(define (integrate/procedure operations environment procedure)
(let ((block (procedure/block procedure))
(name (procedure/name procedure))
rest
body)))))))
\f
-
-;;; INTEGRATE-COMBINATION
(define integrate-combination-dispatch-vector
(expression/make-dispatch-vector))
((expression/method integrate-combination-dispatch-vector operator)
expression operations environment block operator operands))
-;;;; access-operator
-(define-method/integrate-combination 'ACCESS
+(define-method/integrate-combination 'access
(lambda (expression operations environment block operator operands)
(integrate/access-operator expression operations environment
block operator operands)))
-(define (integrate/access-operator expression operations environment block operator operands)
+(define (integrate/access-operator expression operations environment block
+ operator operands)
(let ((name (access/name operator))
(environment*
- (integrate/expression operations environment (access/environment operator))))
+ (integrate/expression operations environment
+ (access/environment operator))))
(define (dont-integrate)
(combination/make
operations name
(lambda (operation info)
(case operation
- ((#F) (dont-integrate))
+ ((#f) (dont-integrate))
- ((EXPAND)
+ ((expand)
(cond ((info expression operands (reference/block operator))
=> (lambda (new-expression)
- (integrate/expression operations environment new-expression)))
+ (integrate/expression operations environment
+ new-expression)))
(else (dont-integrate))))
- ((IGNORE)
+ ((ignore)
(ignored-variable-warning (variable/name name))
(dont-integrate))
- ((INTEGRATE INTEGRATE-OPERATOR)
+ ((integrate integrate-operator)
(let ((new-operator
(reassign operator
- (copy/expression/intern block (integration-info/expression info)))))
- (integrate/combination expression operations environment block new-operator operands)))
+ (copy/expression/intern
+ block
+ (integration-info/expression info)))))
+ (integrate/combination expression operations environment block
+ new-operator operands)))
(else
(error "unknown operation" operation))))
dont-integrate))))
-;;; assignment-operator
-(define-method/integrate-combination 'ASSIGNMENT
+(define-method/integrate-combination 'assignment
(lambda (expression operations environment block operator operands)
(warn "Value of assignment used as an operator.")
;; We don't try to make sense of this, we just
(integrate/expression operations environment operator)
operands)))
-;;; combination-operator
-(define-method/integrate-combination 'COMBINATION
+(define-method/integrate-combination 'combination
(lambda (expression operations environment block operator operands)
- (integrate-combination/default expression operations environment block operator operands)))
-
-;;; conditional-operator
-(define-method/integrate-combination 'CONDITIONAL
+ (integrate-combination/default expression operations environment block
+ operator operands)))
+\f
+(define-method/integrate-combination 'conditional
(lambda (expression operations environment block operator operands)
- (integrate-combination/default expression operations environment block operator operands)))
+ (integrate-combination/default expression operations environment block
+ operator operands)))
-;;; constant-operator
(define sf:enable-elide-double-negatives? #t)
-(define-method/integrate-combination 'CONSTANT
+(define-method/integrate-combination 'constant
(lambda (expression operations environment block operator operands)
;; Elide a double negative only if it doesn't change the type of the answer.
(cond ((and (expression/constant-eq? operator (ucode-primitive not))
(declare (ignore operations environment))
(combination/make expression block operator operands))
-;;; declaration-operator
-(define-method/integrate-combination 'DECLARATION
+(define-method/integrate-combination 'declaration
(lambda (expression operations environment block operator operands)
- (integrate-combination/default expression operations environment block operator operands)))
+ (integrate-combination/default expression operations environment block
+ operator operands)))
-;;; delay-operator
-(define-method/integrate-combination 'DELAY
+(define-method/integrate-combination 'delay
(lambda (expression operations environment block operator operands)
;; Nonsense - generate a warning.
- (warn "Delayed object in operator position. This will cause a runtime error.")
+ (warn
+ "Delayed object in operator position. This will cause a runtime error.")
(combination/make expression
block
(integrate/expression operations environment operator)
operands)))
-;;; disjunction-operator
-(define-method/integrate-combination 'DISJUNCTION
+(define-method/integrate-combination 'disjunction
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
block operator operands)))
-;;; open-block-operator
-(define-method/integrate-combination 'OPEN-BLOCK
+(define-method/integrate-combination 'open-block
(lambda (expression operations environment block operator operands)
(declare (ignore expression operations environment block operator operands))
;; This shouldn't be possible.
(error "INTERNAL-ERROR: integrate-combination 'open-block")))
-;;; procedure-operator (let)
-(define-method/integrate-combination 'PROCEDURE
+(define-method/integrate-combination 'procedure
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
block operator operands)))
(simulate-application environment block
procedure operands)
procedure))
-
-;;; quotation-operator
-(define-method/integrate-combination 'QUOTATION
+\f
+(define-method/integrate-combination 'quotation
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
block operator operands)))
-;;; reference-operator
-(define-method/integrate-combination 'REFERENCE
+(define-method/integrate-combination 'reference
(lambda (expression operations environment block operator operands)
(integrate/reference-operator expression operations environment
block operator operands)))
(operations/lookup operations variable
(lambda (operation info)
(case operation
- ((#F) (integration-failure))
+ ((#f) (integration-failure))
- ((EXPAND)
- (let ((new-expression (info expression operands (reference/block operator))))
+ ((expand)
+ (let ((new-expression
+ (info expression operands (reference/block operator))))
(if new-expression
(begin
(variable/integrated! variable)
- (integrate/expression operations environment new-expression))
+ (integrate/expression operations environment
+ new-expression))
(integration-failure))))
- ((IGNORE)
+ ((ignore)
(ignored-variable-warning (variable/name variable))
(integration-failure))
- ((INTEGRATE INTEGRATE-OPERATOR)
+ ((integrate integrate-operator)
(let ((new-expression (integrate/name expression
operator info environment)))
(if new-expression
(error "Unknown operation" operation))))
integration-failure))))
-;;; sequence-operator
-(define-method/integrate-combination 'SEQUENCE
+(define-method/integrate-combination 'sequence
(lambda (expression operations environment block operator operands)
(integrate-combination/default expression operations environment
block operator operands)))
-;;; the-environment-operator
-(define-method/integrate-combination 'THE-ENVIRONMENT
+(define-method/integrate-combination 'the-environment
(lambda (expression operations environment block operator operands)
(warn "(THE-ENVIRONMENT) used as an operator. Will cause a runtime error.")
(combination/make expression block
(integrate/expression operations environment operator)
operands)))
-
+\f
(define (integrate-combination/default expression operations environment
block operator operands)
(combination/make
(cond ((constant? operand)
(if (null? (constant/value operand))
'()
- 'FAIL))
+ 'fail))
((not (scode-combination? operand))
- 'FAIL)
+ 'fail)
(else
(let ((rator (combination/operator operand)))
(if (or (and (constant? rator)
(eq? 'cons (global-ref? rator)))
(let* ((rands (combination/operands operand))
(next (check (cadr rands))))
- (if (eq? next 'FAIL)
- 'FAIL
+ (if (eq? next 'fail)
+ 'fail
(cons (car rands) next)))
- 'FAIL)))))
+ 'fail)))))
(and (not (null? operands))
(let ((tail (check (car (last-pair operands)))))
- (and (not (eq? tail 'FAIL))
+ (and (not (eq? tail 'fail))
(append (except-last-pair operands)
tail)))))
\f
(define (delayed-integration/in-progress? delayed-integration)
- (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
+ (eq? (delayed-integration/state delayed-integration) 'being-integrated))
(define (delayed-integration/force delayed-integration)
(case (delayed-integration/state delayed-integration)
- ((NOT-INTEGRATED)
+ ((not-integrated)
(let ((value
(let ((environment
(delayed-integration/environment delayed-integration))
(delayed-integration/operations delayed-integration))
(expression (delayed-integration/value delayed-integration)))
(set-delayed-integration/state! delayed-integration
- 'BEING-INTEGRATED)
+ 'being-integrated)
(set-delayed-integration/environment! delayed-integration #f)
(set-delayed-integration/operations! delayed-integration #f)
(set-delayed-integration/value! delayed-integration #f)
(integrate/expression operations environment expression))))
- (set-delayed-integration/state! delayed-integration 'INTEGRATED)
+ (set-delayed-integration/state! delayed-integration 'integrated)
(set-delayed-integration/value! delayed-integration value)))
- ((INTEGRATED) 'DONE)
- ((BEING-INTEGRATED)
+ ((integrated) 'done)
+ ((being-integrated)
(error "Attempt to re-force delayed integration"
delayed-integration))
(else
(define (sf/internal input-pathname bin-pathname spec-pathname
environment declarations)
spec-pathname ;ignored
- (with-simple-restart 'CONTINUE
+ (with-simple-restart 'continue
(string-append "Skip processing file " (->namestring input-pathname))
(lambda ()
(let ((do-it
(let ((start-date (get-decoded-time)))
(lambda ()
(fasdump (make-scode-comment
- `((SOURCE-FILE . ,(->namestring input-pathname))
- (DATE ,(decoded-time/year start-date)
+ `((source-file . ,(->namestring input-pathname))
+ (date ,(decoded-time/year start-date)
,(decoded-time/month start-date)
,(decoded-time/day start-date))
- (TIME ,(decoded-time/hour start-date)
+ (time ,(decoded-time/hour start-date)
,(decoded-time/minute start-date)
,(decoded-time/second start-date)))
(sf/file->scode input-pathname bin-pathname
(pathname-directory input-pathname)
#f
externs-pathname-type
- 'NEWEST)))
+ 'newest)))
(receive (expression externs-block externs)
(integrate/file input-pathname
(and output-pathname
"ext")
(define sf/default-externs-pathname
- (make-pathname #f #f #f #f externs-pathname-type 'NEWEST))
+ (make-pathname #f #f #f #f externs-pathname-type 'newest))
\f
(define (read-externs-file pathname)
(let ((pathname (merge-pathnames pathname sf/default-externs-pathname)))
(environment-lookup system-global-environment name)))
(if (not (memq (microcode-type/code->name
(object-type object))
- '(BIGNUM
- CHARACTER
- CONSTANT
- FALSE
- FIXNUM
- FLONUM
- INTERNED-SYMBOL
- RATNUM
- RECNUM
- UNINTERNED-SYMBOL)))
+ '(bignum
+ character
+ constant
+ false
+ fixnum
+ flonum
+ interned-symbol
+ ratnum
+ recnum
+ uninterned-symbol)))
(error "USUAL-INTEGRATIONS: not a constant" name))
(constant->integration-info object)))
usual-integrations/constant-names))
#f
block scode-lambda-name:let variables '() #f
(let ((block (block/make block #t '())))
- (let ((variable (variable/make&bind! block 'RECEIVER)))
+ (let ((variable (variable/make&bind! block 'receiver)))
(procedure/make
#f block scode-lambda-name:unnamed (list variable) '() #f
(declaration/make
;; The receiver is used only once, and all its operand
;; expressions are effect-free, so integrating here is
;; safe.
- (declarations/parse block '((INTEGRATE-OPERATOR RECEIVER)))
+ (declarations/parse block '((integrate-operator receiver)))
(combination/make #f
block
(reference/make #f block variable)
;;; Kludge for EXPAND-OPERATOR declaration.
(define expander-evaluation-environment
- (->environment '(SCODE-OPTIMIZER EXPANSION)))
\ No newline at end of file
+ (->environment '(scode-optimizer expansion)))
\ No newline at end of file
(if (not top-level?)
(error "Open blocks allowed only at top level:" expression))
(let ((declarations (scode-open-block-declarations expression)))
- (if (not (assq 'USUAL-INTEGRATIONS declarations))
+ (if (not (assq 'usual-integrations declarations))
(ui-warning))
(transform/open-block* expression
block
(define transform/dispatch
(make-scode-walker
transform/constant
- `((ACCESS ,transform/access)
- (ASSIGNMENT ,transform/assignment)
- (COMBINATION ,transform/combination)
- (COMMENT ,transform/comment)
- (CONDITIONAL ,transform/conditional)
- (DECLARATION ,transform/declaration)
- (DEFINITION ,transform/definition)
- (DELAY ,transform/delay)
- (DISJUNCTION ,transform/disjunction)
- (LAMBDA ,transform/lambda)
- (OPEN-BLOCK ,transform/open-block)
- (QUOTATION ,transform/quotation)
- (SEQUENCE ,transform/sequence)
- (THE-ENVIRONMENT ,transform/the-environment)
- (VARIABLE ,transform/variable))))
\ No newline at end of file
+ `((access ,transform/access)
+ (assignment ,transform/assignment)
+ (combination ,transform/combination)
+ (comment ,transform/comment)
+ (conditional ,transform/conditional)
+ (declaration ,transform/declaration)
+ (definition ,transform/definition)
+ (delay ,transform/delay)
+ (disjunction ,transform/disjunction)
+ (lambda ,transform/lambda)
+ (open-block ,transform/open-block)
+ (quotation ,transform/quotation)
+ (sequence ,transform/sequence)
+ (the-environment ,transform/the-environment)
+ (variable ,transform/variable))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff