From: Chris Hanson Date: Mon, 2 Apr 2018 06:56:25 +0000 (-0700) Subject: Downcase a lot more symbols and constants. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~137 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6b2892fabc38cdac41c7f5f2c47515421fd0cfbe;p=mit-scheme.git Downcase a lot more symbols and constants. --- diff --git a/src/cref/anfile.scm b/src/cref/anfile.scm index c038c3ecf..330c0b362 100644 --- a/src/cref/anfile.scm +++ b/src/cref/anfile.scm @@ -37,7 +37,7 @@ USA. (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)))) @@ -65,14 +65,14 @@ USA. (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) @@ -147,18 +147,18 @@ USA. (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) diff --git a/src/cref/conpkg.scm b/src/cref/conpkg.scm index 481dfd07c..6557fc6c1 100644 --- a/src/cref/conpkg.scm +++ b/src/cref/conpkg.scm @@ -30,7 +30,7 @@ USA. (integrate-external "object")) (define (construct-external-descriptions pmodel) - (vector 'PACKAGE-DESCRIPTIONS ;tag + (vector 'package-descriptions ;tag 2 ;version (list->vector (map cdr diff --git a/src/cref/object.scm b/src/cref/object.scm index ec4832153..d4f1d7c81 100644 --- a/src/cref/object.scm +++ b/src/cref/object.scm @@ -51,7 +51,7 @@ USA. (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) @@ -107,7 +107,7 @@ USA. (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))))))) @@ -170,7 +170,7 @@ USA. (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))))))) diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm index 98fc91d04..75dd00152 100644 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@ -80,7 +80,7 @@ USA. (let ((description (car descriptions)) (descriptions (cdr descriptions))) (case (car description) - ((DEFINE-PACKAGE) + ((define-package) (loop descriptions (cons (cdr description) packages) extensions @@ -88,7 +88,7 @@ USA. (cons (cdr description) loads) loads) globals)) - ((EXTEND-PACKAGE) + ((extend-package) (loop descriptions packages (cons (cdr description) extensions) @@ -96,13 +96,13 @@ USA. (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 @@ -269,41 +269,41 @@ USA. (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)) @@ -319,28 +319,28 @@ USA. (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)) @@ -357,20 +357,20 @@ USA. (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)) @@ -388,24 +388,24 @@ USA. 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! @@ -424,7 +424,7 @@ USA. (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) @@ -432,7 +432,7 @@ USA. (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)) @@ -479,7 +479,7 @@ USA. (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 @@ -494,7 +494,7 @@ USA. (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))))))) @@ -510,7 +510,7 @@ USA. (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 @@ -546,7 +546,7 @@ USA. (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) @@ -579,7 +579,7 @@ USA. (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)))) diff --git a/src/cref/toplev.scm b/src/cref/toplev.scm index e441ab023..426e22088 100644 --- a/src/cref/toplev.scm +++ b/src/cref/toplev.scm @@ -38,7 +38,7 @@ USA. (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)))))) @@ -52,7 +52,7 @@ USA. #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)) @@ -71,7 +71,7 @@ USA. (read-package-model filename os-type)))))) (define os-types - '(NT UNIX)) + '(nt unix)) (define cref/generate-cref (generate/common diff --git a/src/runtime/advice.scm b/src/runtime/advice.scm index 8abbf5f02..a0f2fc475 100644 --- a/src/runtime/advice.scm +++ b/src/runtime/advice.scm @@ -62,7 +62,7 @@ USA. (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) @@ -86,21 +86,21 @@ USA. (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 diff --git a/src/runtime/apply.scm b/src/runtime/apply.scm index 6528b467a..19e8802ca 100644 --- a/src/runtime/apply.scm +++ b/src/runtime/apply.scm @@ -48,22 +48,22 @@ USA. (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)) @@ -98,9 +98,9 @@ USA. (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 diff --git a/src/runtime/arith.scm b/src/runtime/arith.scm index 18b349a89..3827e919f 100644 --- a/src/runtime/arith.scm +++ b/src/runtime/arith.scm @@ -172,21 +172,21 @@ USA. (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 &/)) @@ -196,33 +196,33 @@ USA. (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 @@ -230,18 +230,18 @@ USA. (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)) @@ -2044,5 +2044,5 @@ USA. (case radix ((B) 2) ((O) 8) - ((D #F) 10) + ((D #f) 10) ((X) 16))))) \ No newline at end of file diff --git a/src/runtime/debug.scm b/src/runtime/debug.scm index e5b17b1fa..e4778af98 100644 --- a/src/runtime/debug.scm +++ b/src/runtime/debug.scm @@ -48,7 +48,7 @@ USA. (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 @@ -105,9 +105,9 @@ USA. (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 @@ -132,7 +132,7 @@ USA. (else (error:wrong-type-argument object "condition or continuation" - 'DEBUG))))) + 'debug))))) (define (count-subproblems dstate) (do ((i 0 (1+ i)) @@ -162,12 +162,12 @@ USA. (stack-frame/reductions (dstate/subproblem dstate))) (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 @@ -233,11 +233,11 @@ USA. (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 @@ -414,7 +414,7 @@ USA. (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) @@ -791,7 +791,7 @@ USA. (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 @@ -813,7 +813,7 @@ USA. (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")))) @@ -841,29 +841,29 @@ USA. ;;;; 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) @@ -923,9 +923,9 @@ USA. (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) diff --git a/src/runtime/defstr.scm b/src/runtime/defstr.scm index ba90d6ea9..4738cddb6 100644 --- a/src/runtime/defstr.scm +++ b/src/runtime/defstr.scm @@ -97,7 +97,7 @@ differences: (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) @@ -109,18 +109,18 @@ differences: (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? @@ -163,7 +163,7 @@ differences: (default-unparser-text context))) (if type-option (option/argument type-option) - 'RECORD) + 'record) tagged? type-name (and tagged? tag-expression) @@ -230,11 +230,11 @@ differences: 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) @@ -266,14 +266,14 @@ differences: (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))) @@ -282,18 +282,18 @@ differences: (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))) @@ -369,109 +369,109 @@ differences: ((2) (if-2 (cadr option) (caddr option))) (else #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)))))) -(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))))) ;;;; Parse slot descriptions @@ -560,7 +560,7 @@ differences: (slots structure/slots)) (define-integrable (structure/record-type? structure) - (eq? (structure/physical-type structure) 'RECORD)) + (eq? (structure/physical-type structure) 'record)) (define-record-type (make-parser-context name use-environment closing-environment) @@ -607,21 +607,21 @@ differences: (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)))) @@ -632,32 +632,32 @@ differences: (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?)))) (define (constructor-definitions structure) @@ -671,11 +671,11 @@ differences: (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) @@ -683,12 +683,12 @@ differences: (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 @@ -705,7 +705,7 @@ differences: (eq? slot rest)) name) ((memq slot optional) - `(IF (DEFAULT-OBJECT? ,name) ,dv ,name)) + `(if (default-object? ,name) ,dv ,name)) (else dv)))) (structure/slots structure))))))))))) @@ -713,13 +713,13 @@ differences: (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) @@ -732,8 +732,8 @@ differences: (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) @@ -745,11 +745,11 @@ differences: (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)))) '()))) diff --git a/src/runtime/dos-pathname.scm b/src/runtime/dos-pathname.scm index 283fa2e1b..900ab52e1 100644 --- a/src/runtime/dos-pathname.scm +++ b/src/runtime/dos-pathname.scm @@ -43,7 +43,7 @@ USA. (define (make-dos-host-type index) (make-host-type index - 'DOS + 'dos dos/parse-namestring dos/pathname->namestring dos/make-pathname @@ -59,7 +59,7 @@ USA. dos/pathname-simplify)) (define (initialize-package!) - (add-pathname-host-type! 'DOS make-dos-host-type)) + (add-pathname-host-type! 'dos make-dos-host-type)) ;;;; Pathname Parser @@ -80,7 +80,7 @@ USA. (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 @@ -93,11 +93,11 @@ USA. (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)) @@ -146,8 +146,8 @@ USA. (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) @@ -159,7 +159,7 @@ USA. (define (parse-directory-component component) (if (string=? ".." component) - 'UP + 'up component)) (define (string-components string delimiters) @@ -180,7 +180,7 @@ USA. (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) @@ -189,7 +189,7 @@ USA. (define (extract string start end) (if (and (fix:= 1 (fix:- end start)) (char=? #\* (string-ref string start))) - 'WILD + 'wild (substring string start end))) ;;;; Pathname Unparser @@ -201,16 +201,16 @@ USA. (%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))) @@ -223,7 +223,7 @@ USA. (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")))) @@ -237,7 +237,7 @@ USA. (define (unparse-component component) (cond ((or (not component) (string? component)) component) - ((eq? component 'WILD) "*") + ((eq? component 'wild) "*") (else (error:illegal-pathname-component component "component")))) ;;;; Pathname Constructors @@ -246,33 +246,33 @@ USA. (%%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) @@ -282,7 +282,7 @@ USA. ;; 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 @@ -290,7 +290,7 @@ USA. (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))))) @@ -305,7 +305,7 @@ USA. (%pathname-directory pathname) #f #f - 'UNSPECIFIC)) + 'unspecific)) (define (dos/file-pathname pathname) (%%make-pathname (%pathname-host pathname) @@ -326,20 +326,20 @@ USA. (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))) @@ -354,7 +354,7 @@ USA. (simplify-directory (except-last-pair directory)) name type - 'UNSPECIFIC)))))) + 'unspecific)))))) ;;;; Miscellaneous @@ -391,9 +391,9 @@ USA. '() (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*)) diff --git a/src/runtime/format.scm b/src/runtime/format.scm index f60d63684..db947adf7 100644 --- a/src/runtime/format.scm +++ b/src/runtime/format.scm @@ -169,14 +169,14 @@ USA. 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)) @@ -187,7 +187,7 @@ USA. (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)))))) @@ -199,7 +199,7 @@ USA. (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 @@ -235,8 +235,8 @@ USA. (#\# ,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 #\~))) diff --git a/src/runtime/gcnote.scm b/src/runtime/gcnote.scm index 2ce0fdc82..ca7c46815 100644 --- a/src/runtime/gcnote.scm +++ b/src/runtime/gcnote.scm @@ -39,7 +39,7 @@ USA. 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)) @@ -100,7 +100,7 @@ USA. (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) @@ -112,7 +112,7 @@ USA. (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)))) diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm index ab720f787..f914a8a79 100644 --- a/src/runtime/http-syntax.scm +++ b/src/runtime/http-syntax.scm @@ -152,7 +152,7 @@ USA. (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)) @@ -235,12 +235,12 @@ USA. (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) @@ -250,11 +250,11 @@ USA. ((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) @@ -282,7 +282,7 @@ USA. (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)) ;;;; Tokens and text @@ -393,7 +393,7 @@ USA. (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))) @@ -697,10 +697,10 @@ USA. (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?) @@ -844,14 +844,14 @@ USA. 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) @@ -866,7 +866,7 @@ USA. (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)) @@ -876,32 +876,32 @@ USA. (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))))) @@ -950,7 +950,7 @@ USA. (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 @@ -973,7 +973,7 @@ USA. ((char=? char #\)) (if (= level 1) (begin - (emit (cons 'COMMENT (fifo))) + (emit (cons 'comment (fifo))) (tokenizer-state:tokenize port emit fifo)) (begin (fifo char) @@ -1286,14 +1286,14 @@ USA. (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" diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index ae6b5b331..0d6ab36e4 100644 --- a/src/runtime/lambda.scm +++ b/src/runtime/lambda.scm @@ -81,15 +81,15 @@ USA. (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 @@ -105,7 +105,7 @@ USA. 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 @@ -117,19 +117,19 @@ USA. 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! @@ -223,7 +223,7 @@ USA. (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))))) @@ -333,7 +333,7 @@ USA. (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))) @@ -423,15 +423,16 @@ USA. (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 diff --git a/src/runtime/microcode-data.scm b/src/runtime/microcode-data.scm index 11bdad46b..f487de259 100644 --- a/src/runtime/microcode-data.scm +++ b/src/runtime/microcode-data.scm @@ -73,11 +73,11 @@ USA. (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) @@ -97,10 +97,10 @@ USA. (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 @@ -215,7 +215,7 @@ contains constants derived from the source program. (- (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))) @@ -291,9 +291,9 @@ contains constants derived from the source program. (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)))) diff --git a/src/runtime/microcode-errors.scm b/src/runtime/microcode-errors.scm index c3c6019da..2a5349b71 100644 --- a/src/runtime/microcode-errors.scm +++ b/src/runtime/microcode-errors.scm @@ -83,7 +83,7 @@ USA. (lambda (continuation . field-values) (error (apply make-condition (cons* continuation - 'BOUND-RESTARTS + 'bound-restarts field-values)))))) (define (initialize-error-hooks!) @@ -97,7 +97,7 @@ USA. ;;;; 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) @@ -111,7 +111,7 @@ USA. 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) @@ -127,7 +127,7 @@ USA. (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) @@ -145,7 +145,7 @@ USA. (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 () @@ -156,7 +156,7 @@ USA. (thunk)))) (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 () @@ -166,7 +166,7 @@ USA. (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 () @@ -180,7 +180,7 @@ USA. (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 () @@ -193,7 +193,7 @@ USA. 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 @@ -212,7 +212,7 @@ USA. (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 @@ -253,7 +253,7 @@ USA. (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) @@ -333,26 +333,26 @@ USA. (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))) (define (file-primitive-description primitive) @@ -409,16 +409,16 @@ USA. (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) @@ -429,17 +429,17 @@ USA. (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) @@ -455,12 +455,12 @@ USA. (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 @@ -468,10 +468,10 @@ USA. ;;;; 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 @@ -486,10 +486,10 @@ USA. (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 @@ -503,10 +503,10 @@ USA. 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 @@ -579,33 +579,33 @@ USA. (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) ;;;; 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) @@ -616,84 +616,84 @@ USA. (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)))))))) (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))) @@ -720,26 +720,26 @@ USA. ;++ 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) (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) @@ -749,7 +749,7 @@ USA. (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)) @@ -758,7 +758,7 @@ USA. (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))) @@ -785,7 +785,7 @@ USA. 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) @@ -804,13 +804,13 @@ USA. (else (error (make-condition))))))))))) -(define-low-level-handler 'SYSTEM-CALL system-call-error-handler) +(define-low-level-handler 'system-call system-call-error-handler) ;;;; 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) @@ -823,59 +823,59 @@ USA. (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) @@ -889,17 +889,17 @@ USA. ;;;; 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) @@ -909,10 +909,10 @@ USA. (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) @@ -931,10 +931,10 @@ USA. (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) @@ -943,18 +943,18 @@ USA. (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) @@ -968,49 +968,49 @@ USA. ;;;; 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) diff --git a/src/runtime/ntprm.scm b/src/runtime/ntprm.scm index a7b22b431..a26b60343 100644 --- a/src/runtime/ntprm.scm +++ b/src/runtime/ntprm.scm @@ -122,7 +122,7 @@ USA. (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)))))) @@ -154,7 +154,7 @@ USA. (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) @@ -165,7 +165,7 @@ USA. (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))) @@ -177,7 +177,7 @@ USA. (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! @@ -189,7 +189,7 @@ USA. (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))) @@ -332,18 +332,18 @@ USA. (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))))) (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) @@ -367,19 +367,19 @@ USA. (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))))) @@ -427,7 +427,7 @@ USA. (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) @@ -526,7 +526,7 @@ USA. (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))) @@ -694,7 +694,7 @@ USA. ((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))))) @@ -702,20 +702,20 @@ USA. (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) diff --git a/src/runtime/numint.scm b/src/runtime/numint.scm index 3f016c069..5a9b93e2c 100644 --- a/src/runtime/numint.scm +++ b/src/runtime/numint.scm @@ -38,8 +38,8 @@ USA. (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 <) @@ -51,8 +51,8 @@ USA. (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 <) @@ -76,7 +76,7 @@ USA. (lambda (self x . xs) self ;ignored (reduce-max/min max/min x xs 'make-max/min-operator)) - #F + #f (lambda (x) x) max/min)) @@ -90,7 +90,7 @@ USA. (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)) @@ -121,7 +121,7 @@ USA. 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)) diff --git a/src/runtime/packag.scm b/src/runtime/packag.scm index 0f3a07c68..7ba4a4e06 100644 --- a/src/runtime/packag.scm +++ b/src/runtime/packag.scm @@ -70,7 +70,7 @@ USA. (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) @@ -152,7 +152,7 @@ USA. (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 () @@ -161,10 +161,10 @@ USA. (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 @@ -227,7 +227,7 @@ USA. (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) @@ -273,7 +273,7 @@ USA. (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?)))) @@ -290,7 +290,7 @@ USA. (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))) @@ -392,7 +392,7 @@ USA. ((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))) @@ -408,7 +408,7 @@ USA. (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))) @@ -468,7 +468,7 @@ USA. ((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) diff --git a/src/runtime/pathname.scm b/src/runtime/pathname.scm index 4044a9522..9567a0148 100644 --- a/src/runtime/pathname.scm +++ b/src/runtime/pathname.scm @@ -122,7 +122,7 @@ these rules: (->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) @@ -130,7 +130,7 @@ these rules: (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))) @@ -165,12 +165,12 @@ these rules: (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))) @@ -303,9 +303,9 @@ these rules: (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 "") @@ -327,7 +327,7 @@ these rules: #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) @@ -346,14 +346,14 @@ these rules: (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) @@ -367,22 +367,22 @@ these rules: (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))) ;;;; 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 @@ -392,11 +392,11 @@ these rules: 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))) @@ -459,7 +459,7 @@ these rules: (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) @@ -471,7 +471,7 @@ these rules: (cond ((not directory) default) ((and (pair? directory) - (eq? (car directory) 'RELATIVE) + (eq? (car directory) 'relative) (pair? default)) (append default (cdr directory))) (else @@ -481,7 +481,7 @@ these rules: (or (%pathname-version pathname) (and (not (%pathname-name pathname)) (%pathname-version defaults)) (if (default-object? default-version) - 'NEWEST + 'newest default-version))))) (define (enough-pathname pathname #!optional defaults) @@ -489,7 +489,7 @@ these rules: (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) @@ -515,7 +515,7 @@ these rules: ;; 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)) @@ -524,7 +524,7 @@ these rules: (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*))) @@ -596,14 +596,14 @@ these rules: (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))) @@ -654,8 +654,8 @@ these rules: (define library-directory-path) (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)) @@ -695,7 +695,7 @@ these rules: 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)))) @@ -726,4 +726,4 @@ these rules: (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 diff --git a/src/runtime/primitive-io.scm b/src/runtime/primitive-io.scm index 30520e9f4..8d5308ea8 100644 --- a/src/runtime/primitive-io.scm +++ b/src/runtime/primitive-io.scm @@ -81,15 +81,15 @@ USA. (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 @@ -189,12 +189,12 @@ USA. 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)))) @@ -217,12 +217,12 @@ USA. 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)))) @@ -529,10 +529,10 @@ USA. (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) @@ -553,10 +553,10 @@ USA. #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))))) @@ -565,23 +565,23 @@ USA. ((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) @@ -616,8 +616,8 @@ USA. (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)))))))) @@ -671,7 +671,7 @@ USA. (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) @@ -713,7 +713,7 @@ USA. 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) @@ -728,8 +728,8 @@ USA. (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))) diff --git a/src/runtime/structure-parser.scm b/src/runtime/structure-parser.scm index 9207138d1..6202e3fb3 100644 --- a/src/runtime/structure-parser.scm +++ b/src/runtime/structure-parser.scm @@ -33,7 +33,7 @@ USA. (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) @@ -48,7 +48,7 @@ USA. (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) @@ -64,7 +64,7 @@ USA. (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) @@ -109,25 +109,25 @@ USA. (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))) (define (get-pattern-compiler name caller-context) @@ -136,8 +136,8 @@ USA. (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) @@ -194,44 +194,44 @@ USA. ;;;; 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)))))) @@ -240,18 +240,18 @@ USA. (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) @@ -259,7 +259,7 @@ USA. `(,callee ,item ,win ,lose)) lose))))) -(define-context-method 'TRANSFORM-VALS 'OBJECT +(define-context-method 'transform-vals 'object (lambda (callee transform) (make-object-parser (lambda (item win lose) @@ -272,17 +272,17 @@ USA. `(,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*) @@ -291,11 +291,11 @@ USA. ,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) @@ -303,15 +303,15 @@ USA. `(,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 @@ -321,22 +321,22 @@ USA. ;;;; 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) @@ -344,15 +344,15 @@ USA. (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 @@ -360,7 +360,7 @@ USA. ,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) @@ -369,7 +369,7 @@ USA. (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 @@ -389,27 +389,27 @@ USA. (make-termination location vals lose))) (make-termination location (null-vals) lose)))))))) -(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 @@ -417,69 +417,69 @@ USA. 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)))) ;;;; 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) @@ -492,13 +492,13 @@ USA. (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) @@ -506,7 +506,7 @@ USA. `(,callee ,items ,win ,lose)) lose))))) -(define-context-method '* 'LIST +(define-context-method '* 'list (lambda (make-body) (make-list-parser (lambda (items win lose) @@ -519,7 +519,7 @@ USA. (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) @@ -534,29 +534,29 @@ USA. ;;;; 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) @@ -569,14 +569,14 @@ USA. (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) @@ -584,7 +584,7 @@ USA. `(,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) @@ -599,7 +599,7 @@ USA. (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) @@ -616,12 +616,12 @@ USA. (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) ''()) @@ -644,7 +644,7 @@ USA. (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) @@ -666,7 +666,7 @@ USA. (loop (cdr vals*))))) (else (error:not-a structure-parser-values? vals - 'MAP-STRUCTURE-PARSER-VALUES))))) + 'map-structure-parser-values))))) (define (structure-parser-values? object) (let loop ((object object)) @@ -688,10 +688,10 @@ USA. (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*) @@ -722,33 +722,33 @@ USA. ;;;; 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) @@ -756,16 +756,16 @@ USA. (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) @@ -838,7 +838,7 @@ USA. (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)))))) @@ -889,7 +889,7 @@ USA. (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) @@ -927,30 +927,30 @@ USA. (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 @@ -958,46 +958,46 @@ USA. (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))))) -(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) @@ -1033,11 +1033,11 @@ USA. 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)))) diff --git a/src/runtime/syntax-rules.scm b/src/runtime/syntax-rules.scm index 74bdb2eb6..b1b076c55 100644 --- a/src/runtime/syntax-rules.scm +++ b/src/runtime/syntax-rules.scm @@ -46,28 +46,28 @@ USA. (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 @@ -82,16 +82,16 @@ USA. ((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)) @@ -104,11 +104,11 @@ USA. (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)) @@ -119,54 +119,54 @@ USA. (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))) (define (generate-output rename compare r-rename sids template) @@ -198,7 +198,7 @@ USA. (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)) @@ -228,9 +228,9 @@ USA. (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)))) @@ -258,26 +258,26 @@ USA. (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 (make-sid name expression control) diff --git a/src/runtime/sysmac.scm b/src/runtime/sysmac.scm index 853da7f2e..a715ad9b9 100644 --- a/src/runtime/sysmac.scm +++ b/src/runtime/sysmac.scm @@ -43,11 +43,11 @@ USA. (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))) @@ -83,14 +83,14 @@ USA. (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 diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index bed9c0fb0..89d3557bf 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -35,7 +35,7 @@ USA. (define-structure (thread (constructor %make-thread (properties)) (conc-name thread/)) - (execution-state 'RUNNING) + (execution-state 'running) ;; One of: ;; RUNNING ;; RUNNING-WITHOUT-PREEMPTION @@ -94,11 +94,11 @@ USA. (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))) (define thread-population) (define first-running-thread) @@ -131,21 +131,21 @@ USA. (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))) @@ -155,7 +155,7 @@ USA. (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!) @@ -196,7 +196,7 @@ USA. (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) @@ -251,7 +251,7 @@ USA. (let ((condition (make-condition condition-type:no-current-thread continuation - 'BOUND-RESTARTS + 'bound-restarts '()))) (signal-thread-event thread (lambda () @@ -270,10 +270,10 @@ USA. (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) @@ -281,7 +281,7 @@ USA. (%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) @@ -341,7 +341,7 @@ USA. (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 @@ -353,28 +353,28 @@ USA. (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))))) (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 @@ -392,7 +392,7 @@ USA. (%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 @@ -436,7 +436,7 @@ USA. (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)))))) @@ -477,10 +477,10 @@ USA. (%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) @@ -503,7 +503,7 @@ USA. (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) @@ -511,7 +511,7 @@ USA. (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) @@ -616,7 +616,7 @@ USA. (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) @@ -625,7 +625,7 @@ USA. (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 () @@ -637,7 +637,7 @@ USA. (lambda () (with-thread-events-blocked (lambda () - (if (eq? result 'INTERRUPT) + (if (eq? result 'interrupt) (suspend-current-thread))))) (lambda () (if (and registration @@ -655,7 +655,7 @@ USA. (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 () @@ -671,14 +671,14 @@ USA. (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 @@ -718,21 +718,21 @@ USA. (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)) @@ -801,7 +801,7 @@ USA. 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) @@ -821,8 +821,8 @@ USA. (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)))))) @@ -874,7 +874,7 @@ USA. (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 @@ -902,7 +902,7 @@ USA. unspecific))) (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?))) @@ -913,7 +913,7 @@ USA. (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)) @@ -926,7 +926,7 @@ USA. (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) @@ -1045,7 +1045,7 @@ USA. (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)) @@ -1094,7 +1094,7 @@ USA. (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) @@ -1164,7 +1164,7 @@ USA. (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) @@ -1177,11 +1177,11 @@ USA. ;;; 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)) (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)) @@ -1201,7 +1201,7 @@ USA. (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))) @@ -1221,7 +1221,7 @@ USA. 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)) @@ -1234,19 +1234,19 @@ USA. #t))))))) (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))) @@ -1263,7 +1263,7 @@ USA. ;;; 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 @@ -1280,7 +1280,7 @@ USA. (%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 @@ -1331,19 +1331,19 @@ USA. (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) @@ -1352,17 +1352,17 @@ USA. (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)) (set! condition-type:thread-detached - (make-condition-type 'THREAD-DETACHED + (make-condition-type 'thread-detached condition-type:thread-control-error '() (lambda (condition port) @@ -1371,12 +1371,12 @@ USA. (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) @@ -1386,15 +1386,15 @@ USA. (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 diff --git a/src/runtime/unix-pathname.scm b/src/runtime/unix-pathname.scm index 1831c545f..e69109f04 100644 --- a/src/runtime/unix-pathname.scm +++ b/src/runtime/unix-pathname.scm @@ -31,7 +31,7 @@ USA. (define (make-unix-host-type index) (make-host-type index - 'UNIX + 'unix unix/parse-namestring unix/pathname->namestring unix/make-pathname @@ -47,7 +47,7 @@ USA. unix/pathname-simplify)) (define (initialize-package!) - (add-pathname-host-type! 'UNIX make-unix-host-type)) + (add-pathname-host-type! 'unix make-unix-host-type)) ;;;; Pathname Parser @@ -59,21 +59,21 @@ USA. (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)) @@ -107,7 +107,7 @@ USA. (else components)))))) (define (simplify-directory directory) - (if (and (eq? (car directory) 'RELATIVE) (null? (cdr directory))) + (if (and (eq? (car directory) 'relative) (null? (cdr directory))) #f directory)) @@ -118,8 +118,8 @@ USA. 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) @@ -140,7 +140,7 @@ USA. (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) @@ -149,7 +149,7 @@ USA. (define (extract string start end) (if (and (fix:= 1 (fix:- end start)) (char=? #\* (string-ref string start))) - 'WILD + 'wild (substring string start end))) ;;;; Pathname Unparser @@ -164,7 +164,7 @@ USA. "") ((pair? directory) (string-append - (if (eq? (car directory) 'ABSOLUTE) "/" "") + (if (eq? (car directory) 'absolute) "/" "") (let loop ((directory (cdr directory))) (if (not (pair? directory)) "" @@ -175,8 +175,8 @@ USA. (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")))) @@ -190,7 +190,7 @@ USA. (define (unparse-component component) (cond ((or (not component) (string? component)) component) - ((eq? component 'WILD) "*") + ((eq? component 'wild) "*") (else (error:illegal-pathname-component component "component")))) ;;;; Pathname Constructors @@ -198,31 +198,31 @@ USA. (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) @@ -235,11 +235,11 @@ USA. (%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) @@ -251,27 +251,27 @@ USA. (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)))) @@ -284,17 +284,17 @@ USA. (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)))))) ;;;; 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) @@ -319,9 +319,9 @@ USA. (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)))) @@ -329,7 +329,7 @@ USA. (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)))) diff --git a/src/runtime/unxdir.scm b/src/runtime/unxdir.scm index 7bd501538..3ce14b6ef 100644 --- a/src/runtime/unxdir.scm +++ b/src/runtime/unxdir.scm @@ -47,8 +47,8 @@ USA. (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))) @@ -60,8 +60,8 @@ USA. (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) @@ -81,8 +81,8 @@ USA. result)))))) (define (match-component pattern instance) - (or (eq? pattern 'WILD) - (eq? pattern #F) + (or (eq? pattern 'wild) + (eq? pattern #f) (equal? pattern instance))) (define (pathnameuri 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))) '()) @@ -186,9 +186,9 @@ USA. '())))) (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)))) (define (remove-dot-segments path) @@ -324,13 +324,13 @@ USA. #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) @@ -927,7 +927,7 @@ USA. (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 @@ -954,7 +954,7 @@ USA. (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)))) @@ -967,11 +967,11 @@ USA. (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) @@ -1020,57 +1020,57 @@ USA. 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))))) (define-ppu-state start-reference diff --git a/src/runtime/wttree.scm b/src/runtime/wttree.scm index 2a162aad7..87d59edaa 100644 --- a/src/runtime/wttree.scm +++ b/src/runtime/wttree.scm @@ -73,38 +73,37 @@ we adopt here, described in ;;; relation. (define-structure - (tree-type - (conc-name tree-type/) - (constructor %make-tree-type)) - (keytree #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)) + (keytree #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)) ;;; 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. diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm index c7827fb1e..7ae294622 100644 --- a/src/sf/analyze.scm +++ b/src/sf/analyze.scm @@ -45,11 +45,11 @@ USA. (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)))) @@ -58,48 +58,48 @@ USA. (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) ;;; EXPRESSION/BOOLEAN? ;; @@ -115,57 +115,57 @@ USA. (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) ;;; EXPRESSION/EFFECT-FREE? ;; @@ -180,13 +180,13 @@ USA. (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) @@ -194,7 +194,7 @@ USA. (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)) @@ -202,16 +202,16 @@ USA. (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)) @@ -220,23 +220,23 @@ USA. ;; 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) ;;; EXPRESSION/FREE-VARIABLES ;; @@ -259,24 +259,24 @@ USA. (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? @@ -288,20 +288,20 @@ USA. (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)))) -(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? @@ -310,7 +310,7 @@ USA. (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) @@ -328,26 +328,26 @@ USA. 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))) @@ -380,22 +380,22 @@ USA. (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)) @@ -410,17 +410,17 @@ USA. (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))) -(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)) @@ -428,7 +428,7 @@ USA. (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 @@ -438,17 +438,17 @@ USA. #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 @@ -458,7 +458,7 @@ USA. #f (sequence/actions expression)))) -(define-method/free-variable? 'THE-ENVIRONMENT false-procedure) +(define-method/free-variable? 'the-environment false-procedure) ;;; EXPRESSION/FREE-VARIABLE-INFO ;; @@ -488,18 +488,18 @@ USA. (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 @@ -511,7 +511,7 @@ USA. (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 @@ -521,22 +521,22 @@ USA. (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))) -(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 @@ -544,7 +544,7 @@ USA. (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) @@ -554,28 +554,28 @@ USA. 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)) @@ -595,11 +595,11 @@ USA. (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)))) @@ -608,42 +608,42 @@ USA. (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) ;;; EXPRESSION/PURE-FALSE? @@ -659,11 +659,11 @@ USA. (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)))) @@ -674,7 +674,7 @@ USA. (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)) @@ -682,38 +682,38 @@ USA. (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) ;;; EXPRESSION/PURE-TRUE? ;; @@ -730,11 +730,11 @@ USA. (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)))) @@ -745,7 +745,7 @@ USA. (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)) @@ -753,37 +753,37 @@ USA. (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) ;;; EXPRESSION/SIZE ;; @@ -801,22 +801,22 @@ USA. (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)) @@ -824,23 +824,23 @@ USA. (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) @@ -849,20 +849,20 @@ USA. 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))) @@ -883,55 +883,55 @@ USA. (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))) @@ -939,18 +939,18 @@ USA. (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))))) diff --git a/src/sf/butils.scm b/src/sf/butils.scm index 2ce4451cb..f2a5f6205 100644 --- a/src/sf/butils.scm +++ b/src/sf/butils.scm @@ -32,7 +32,7 @@ USA. (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 diff --git a/src/sf/cgen.scm b/src/sf/cgen.scm index ac1edbdf5..6825765c1 100644 --- a/src/sf/cgen.scm +++ b/src/sf/cgen.scm @@ -83,17 +83,17 @@ USA. ;; 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) @@ -128,53 +128,53 @@ USA. (set-cdr! interns (cons association (cdr interns))) association)))) -(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))))) -(define-method/cgen 'PROCEDURE +(define-method/cgen 'procedure (lambda (interns procedure) interns ; ignored (make-lambda* (procedure/name procedure) @@ -212,16 +212,16 @@ USA. (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? @@ -239,7 +239,7 @@ USA. 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))) diff --git a/src/sf/chtype.scm b/src/sf/chtype.scm index a6792a080..ae3d157d4 100644 --- a/src/sf/chtype.scm +++ b/src/sf/chtype.scm @@ -61,42 +61,42 @@ USA. (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) -(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) @@ -104,20 +104,20 @@ USA. (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 diff --git a/src/sf/copy.scm b/src/sf/copy.scm index 6e6f44b44..148ab1819 100644 --- a/src/sf/copy.scm +++ b/src/sf/copy.scm @@ -170,7 +170,7 @@ USA. (lambda (expression) (copy/expression block environment expression))))) -(define-method/copy 'ACCESS +(define-method/copy 'access (lambda (block environment expression) (call-with-values (lambda () @@ -183,7 +183,7 @@ USA. (access/environment expression)) (access/name expression)))))) -(define-method/copy 'ASSIGNMENT +(define-method/copy 'assignment (lambda (block environment expression) (assignment/make (assignment/scode expression) @@ -191,7 +191,7 @@ USA. (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) @@ -199,7 +199,7 @@ USA. (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) @@ -207,12 +207,12 @@ USA. (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) @@ -221,13 +221,13 @@ USA. (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) @@ -236,7 +236,7 @@ USA. environment (disjunction/alternative expression))))) -(define-method/copy 'PROCEDURE +(define-method/copy 'procedure (lambda (block environment procedure) (call-with-values (lambda () @@ -255,7 +255,7 @@ USA. environment (procedure/body procedure)))))))) -(define-method/copy 'OPEN-BLOCK +(define-method/copy 'open-block (lambda (block environment expression) (call-with-values (lambda () @@ -272,25 +272,25 @@ USA. (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 diff --git a/src/sf/gconst.scm b/src/sf/gconst.scm index 6b4cc28f7..6cdb231b8 100644 --- a/src/sf/gconst.scm +++ b/src/sf/gconst.scm @@ -30,198 +30,198 @@ USA. (declare (usual-integrations)) (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 diff --git a/src/sf/object.scm b/src/sf/object.scm index 4f1b66540..39e56cd95 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -72,12 +72,12 @@ USA. (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)))))) @@ -117,19 +117,19 @@ USA. (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) @@ -172,7 +172,7 @@ USA. (named delayed-integration/enumerand) (conc-name delayed-integration/) (constructor delayed-integration/make (operations value))) - (state 'NOT-INTEGRATED) + (state 'not-integrated) (environment #f) operations value) @@ -221,44 +221,44 @@ USA. (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. @@ -278,20 +278,20 @@ USA. (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. @@ -357,85 +357,85 @@ USA. &/ -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) @@ -613,20 +613,20 @@ USA. (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 diff --git a/src/sf/pardec.scm b/src/sf/pardec.scm index 273384c6c..ce06aa042 100644 --- a/src/sf/pardec.scm +++ b/src/sf/pardec.scm @@ -40,20 +40,20 @@ USA. 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) @@ -70,9 +70,9 @@ USA. 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)))) @@ -138,7 +138,7 @@ USA. (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) @@ -166,12 +166,12 @@ USA. '()) (define (known-declaration? operation) - (or (eq? operation 'EXPAND) ; this one is special + (or (eq? operation 'expand) ; this one is special (assq operation known-declarations))) ;;;; 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 @@ -211,7 +211,7 @@ USA. (cons (make-declaration operation variable value - 'GLOBAL) + 'global) declarations)) (set! remaining (cons (vector operation name value) @@ -220,13 +220,13 @@ USA. (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 @@ -240,7 +240,7 @@ USA. (vector-ref remaining 0) (variable/make&bind! top-level-block (vector-ref remaining 1)) (vector-ref remaining 2) - 'GLOBAL))) + 'global))) remaining)))) (define (define-integration-declaration operation) @@ -248,13 +248,13 @@ USA. (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) @@ -267,7 +267,7 @@ USA. (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)) @@ -280,7 +280,7 @@ USA. name) (make-integration-info (copy/expression/extern block value)) - 'TOP-LEVEL)))))) + 'top-level)))))) externs)))) (append-map (lambda (specification) (let ((value @@ -323,7 +323,7 @@ USA. ;; 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))) @@ -337,7 +337,7 @@ USA. ;; 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 @@ -355,23 +355,23 @@ USA. name) (loop (cdr names) variables)))) variables)))) - (make-declarations 'IGNORE + (make-declarations 'ignore variables - 'NO-VALUES - 'LOCAL)))) + 'no-values + 'local)))) ;;;; 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) @@ -383,14 +383,14 @@ USA. 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)) @@ -399,15 +399,15 @@ USA. (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)))) @@ -415,21 +415,21 @@ USA. (error "Illegal name in replacement:" name)))) (make-dumpable-expander (replacement/make replacement block) - `(REPLACE-OPERATOR ,replacement)) - 'LOCAL)) + `(replace-operator ,replacement)) + 'local)) replacements))) (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)))) @@ -448,12 +448,12 @@ USA. ;;; 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 diff --git a/src/sf/reduct.scm b/src/sf/reduct.scm index 9c09fef9d..69f629748 100644 --- a/src/sf/reduct.scm +++ b/src/sf/reduct.scm @@ -183,7 +183,7 @@ Examples: (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)) @@ -193,12 +193,12 @@ Examples: (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)))) @@ -294,7 +294,7 @@ Examples: 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 @@ -366,7 +366,7 @@ Examples: (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))) @@ -391,31 +391,31 @@ Examples: (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)))) ;;;; 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) @@ -433,7 +433,7 @@ Examples: (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 @@ -445,46 +445,46 @@ Examples: '() 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)))))))))) ;;;; Replacement top level @@ -532,7 +532,7 @@ Examples: (define (expr->case expr) (cons (and (symbol? expr) expr) - (->expression 'REPLACE-OPERATOR + (->expression 'replace-operator expr block))) @@ -555,7 +555,7 @@ Examples: 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) diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 791f89c3b..9a5349c92 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -93,8 +93,7 @@ USA. (define define-method/integrate (expression/make-method-definer dispatch-vector)) -;;;; ACCESS -(define-method/integrate 'ACCESS +(define-method/integrate 'access (lambda (operations environment expression) (let ((environment* (integrate/expression operations environment (access/environment expression))) @@ -111,18 +110,18 @@ USA. 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)) @@ -130,17 +129,16 @@ USA. (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)))) @@ -154,8 +152,7 @@ USA. environment (assignment/value assignment)))))) -;;;; COMBINATION -(define-method/integrate 'COMBINATION +(define-method/integrate 'combination (lambda (operations environment combination) (integrate/combination combination operations environment @@ -164,9 +161,8 @@ USA. (integrate/expressions operations environment (combination/operands combination))))) - -;;;; CONDITIONAL -(define-method/integrate 'CONDITIONAL + +(define-method/integrate 'conditional (lambda (operations environment expression) (integrate/conditional operations environment expression (integrate/expression @@ -208,19 +204,18 @@ USA. (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 @@ -234,17 +229,14 @@ USA. (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 + +(define-method/integrate 'disjunction (lambda (operations environment expression) (integrate/disjunction operations environment expression @@ -289,7 +281,7 @@ USA. 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)) @@ -297,15 +289,13 @@ USA. (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))) @@ -319,11 +309,10 @@ USA. (lambda (operations environment expression) operations environment ;ignore expression))) - -;;;; Reference + (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) @@ -334,14 +323,14 @@ USA. 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 @@ -349,9 +338,10 @@ USA. 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 @@ -364,16 +354,14 @@ USA. (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 @@ -435,7 +423,7 @@ USA. (not (variable/referenced variable)) (not (variable/may-ignore? variable)) (not (variable/must-ignore? variable)))) - + (define (integrate/procedure operations environment procedure) (let ((block (procedure/block procedure)) (name (procedure/name procedure)) @@ -473,8 +461,6 @@ USA. rest body))))))) - -;;; INTEGRATE-COMBINATION (define integrate-combination-dispatch-vector (expression/make-dispatch-vector)) @@ -486,16 +472,17 @@ USA. ((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 @@ -510,30 +497,33 @@ USA. 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 @@ -543,20 +533,19 @@ USA. (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))) + +(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)) @@ -588,36 +577,33 @@ USA. (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))) @@ -628,15 +614,13 @@ USA. (simulate-application environment block procedure operands) procedure)) - -;;; quotation-operator -(define-method/integrate-combination 'QUOTATION + +(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))) @@ -651,21 +635,23 @@ USA. (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 @@ -679,20 +665,18 @@ USA. (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))) - + (define (integrate-combination/default expression operations environment block operator operands) (combination/make @@ -722,9 +706,9 @@ USA. (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) @@ -733,14 +717,14 @@ USA. (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))))) @@ -923,11 +907,11 @@ USA. (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)) @@ -935,15 +919,15 @@ USA. (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 diff --git a/src/sf/toplev.scm b/src/sf/toplev.scm index 889eb8c43..fbceaeebd 100644 --- a/src/sf/toplev.scm +++ b/src/sf/toplev.scm @@ -122,18 +122,18 @@ USA. (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 @@ -170,7 +170,7 @@ USA. (pathname-directory input-pathname) #f externs-pathname-type - 'NEWEST))) + 'newest))) (receive (expression externs-block externs) (integrate/file input-pathname (and output-pathname @@ -195,7 +195,7 @@ USA. "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)) (define (read-externs-file pathname) (let ((pathname (merge-pathnames pathname sf/default-externs-pathname))) diff --git a/src/sf/usicon.scm b/src/sf/usicon.scm index 47965f5c7..e3440eae6 100644 --- a/src/sf/usicon.scm +++ b/src/sf/usicon.scm @@ -43,16 +43,16 @@ USA. (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)) diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index 9f392a898..45697ea26 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -352,7 +352,7 @@ USA. #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 @@ -360,7 +360,7 @@ USA. ;; 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) @@ -889,4 +889,4 @@ USA. ;;; 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 diff --git a/src/sf/xform.scm b/src/sf/xform.scm index 3e794bd63..a3e13b700 100644 --- a/src/sf/xform.scm +++ b/src/sf/xform.scm @@ -58,7 +58,7 @@ USA. (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 @@ -324,18 +324,18 @@ USA. (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