+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.2 1987/03/19 00:49:46 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Assembler Syntax Macros
-
-(declare (usual-integrations))
-\f
-(syntax-table-define assembler-syntax-table 'DEFINE-INSTRUCTION
- (macro (keyword . rules)
- `(ADD-INSTRUCTION!
- ',keyword
- ,(compile-database rules
- (lambda (pattern actions)
- (if (null? actions)
- (error "DEFINE-INSTRUCTION: Too few forms")
- (parse-word (car actions) (cdr actions))))))))
-
-(define (compile-database cases procedure)
- `(LIST
- ,@(map (lambda (case)
- (parse-rule (car case) (cdr case)
- (lambda (pattern names transformer qualifier actions)
- `(CONS ',pattern
- ,(rule-result-expression names
- transformer
- qualifier
- (procedure pattern
- actions))))))
- cases)))
-\f
-;;;; Group Optimization
-
-(define optimize-group-syntax
- (let ()
- (define (find-constant components)
- (cond ((null? components)
- '())
- ((car-constant? components)
- (compact (car-constant-value components)
- (cdr components)))
- (else
- (cons (car components)
- (find-constant (cdr components))))))
-
- (define (compact bit-string components)
- (cond ((null? components)
- (cons (make-constant bit-string) '()))
- ((car-constant? components)
- (compact (bit-string-append (car-constant-value components)
- bit-string)
- (cdr components)))
- (else
- (cons (make-constant bit-string)
- (cons (car components)
- (find-constant (cdr components)))))))
-
- (define-integrable (car-constant? expression)
- (and (eq? (caar expression) 'QUOTE)
- (bit-string? (cadar expression))))
-
- (define-integrable (car-constant-value constant)
- (cadar constant))
-
- (define-integrable (make-constant bit-string)
- `',bit-string)
-
- (lambda components
- (let ((components (find-constant components)))
- (cond ((null? components)
- (error "OPTIMIZE-GROUP-SYNTAX: No components in group!"))
- ((null? (cdr components))
- (car components))
- (else
- `(OPTIMIZE-GROUP ,@components)))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.26 1987/03/19 00:50:04 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; LAP Code Generation
-
-(declare (usual-integrations))
-\f
-(define *block-start-label*)
-(define *code-object-label*)
-(define *code-object-entry*)
-(define *current-rnode*)
-(define *dead-registers*)
-
-(define (generate-lap quotations procedures continuations receiver)
- (with-new-node-marks
- (lambda ()
- (fluid-let ((*next-constant* 0)
- (*interned-constants* '())
- (*block-start-label* (generate-label))
- (*code-object-label*)
- (*code-object-entry*))
- (for-each (lambda (quotation)
- (cgen-entry quotation quotation-rtl-entry))
- quotations)
- (for-each (lambda (procedure)
- (cgen-entry procedure procedure-rtl-entry))
- procedures)
- (for-each (lambda (continuation)
- (cgen-entry continuation continuation-rtl-entry))
- continuations)
- (receiver *interned-constants* *block-start-label*)))))
-
-(define (cgen-entry object extract-entry)
- (set! *code-object-label* (code-object-label-initialize object))
- (let ((rnode (extract-entry object)))
- (set! *code-object-entry* rnode)
- (cgen-rnode rnode)))
-
-(define *cgen-rules*
- '())
-
-(define (add-statement-rule! pattern result-procedure)
- (set! *cgen-rules*
- (cons (cons pattern result-procedure)
- *cgen-rules*))
- pattern)
-\f
-(define (cgen-rnode rnode)
- (define (cgen-right-node edge)
- (let ((next (edge-next-node edge)))
- (if (and next (not (node-marked? next)))
- (begin (if (node-previous>1? next)
- (let ((snode (statement->snode '(NOOP))))
- (set-rnode-lap! snode
- (clear-map-instructions
- (rnode-register-map rnode)))
- (node-mark! snode)
- (edge-insert-snode! edge snode)))
- (cgen-rnode next)))))
- (node-mark! rnode)
- ;; LOOP is for easy restart while debugging.
- (let loop ()
- (let ((match-result (pattern-lookup *cgen-rules* (rnode-rtl rnode))))
- (if match-result
- (fluid-let ((*current-rnode* rnode)
- (*dead-registers* (rnode-dead-registers rnode))
- (*register-map* (rnode-input-register-map rnode))
- (*prefix-instructions* '())
- (*needed-registers* '()))
- (let ((instructions (match-result)))
- (set-rnode-lap! rnode
- (append! *prefix-instructions* instructions)))
- (delete-dead-registers!)
- (set-rnode-register-map! rnode *register-map*))
- (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode))
- (loop)))))
- (if (rtl-snode? rnode)
- (cgen-right-node (snode-next-edge rnode))
- (begin (cgen-right-node (pnode-consequent-edge rnode))
- (cgen-right-node (pnode-alternative-edge rnode)))))
-
-(define (rnode-input-register-map rnode)
- (if (or (eq? rnode *code-object-entry*)
- (not (node-previous=1? rnode)))
- (empty-register-map)
- (let ((previous (node-previous-first rnode)))
- (let ((map (rnode-register-map previous)))
- (if (rtl-pnode? previous)
- (delete-pseudo-registers
- map
- (regset->list
- (regset-difference
- (bblock-live-at-exit (node-bblock previous))
- (bblock-live-at-entry (node-bblock rnode))))
- (lambda (map aliases) map))
- map)))))
-\f
-;;;; Machine independent stuff
-
-(define *register-map*)
-(define *prefix-instructions*)
-(define *needed-registers*)
-
-(define-integrable (prefix-instructions! instructions)
- (set! *prefix-instructions* (append! *prefix-instructions* instructions)))
-
-(define-integrable (need-register! register)
- (set! *needed-registers* (cons register *needed-registers*)))
-
-(define (maybe-need-register! register)
- (if register (need-register! register))
- register)
-
-(define-integrable (register-alias register type)
- (maybe-need-register! (pseudo-register-alias *register-map* type register)))
-
-(define-integrable (register-alias-alternate register type)
- (maybe-need-register! (machine-register-alias *register-map* type register)))
-
-(define-integrable (register-type? register type)
- (or (not type)
- (eq? (register-type register) type)))
-
-(define ((register-type-predicate type) register)
- (register-type? register type))
-
-(define-integrable (dead-register? register)
- (memv register *dead-registers*))
-\f
-(define (guarantee-machine-register! register type)
- (if (and (machine-register? register)
- (register-type? register type))
- register
- (load-alias-register! register type)))
-
-(define (load-alias-register! register type)
- (bind-allocator-values (load-alias-register *register-map* type
- *needed-registers* register)
- store-allocator-values!))
-
-(define (allocate-alias-register! register type)
- (bind-allocator-values (allocate-alias-register *register-map* type
- *needed-registers* register)
- (lambda (alias map instructions)
- (store-allocator-values! alias
- (delete-other-locations map alias)
- instructions))))
-
-(define (allocate-assignment-alias! target type)
- (let ((target (allocate-alias-register! target type)))
- (delete-dead-registers!)
- target))
-
-(define (allocate-temporary-register! type)
- (bind-allocator-values (allocate-temporary-register *register-map* type
- *needed-registers*)
- store-allocator-values!))
-
-(define (store-allocator-values! alias map instructions)
- (need-register! alias)
- (set! *register-map* map)
- (prefix-instructions! instructions)
- alias)
-\f
-(define (move-to-alias-register! source type target)
- (reuse-pseudo-register-alias! source type
- (lambda (reusable-alias)
- (add-pseudo-register-alias! target reusable-alias))
- (lambda ()
- (allocate-alias-register! target type))))
-
-(define (move-to-temporary-register! source type)
- (reuse-pseudo-register-alias! source type
- need-register!
- (lambda ()
- (allocate-temporary-register! type))))
-
-(define (reuse-pseudo-register-alias! source type if-reusable if-not)
- ;; IF-NOT is assumed to return a machine register.
- (let ((reusable-alias
- (and (dead-register? source)
- (register-alias source type))))
- (if reusable-alias
- (begin (delete-dead-registers!)
- (if-reusable reusable-alias)
- (register-reference reusable-alias))
- (let ((alias (if (machine-register? source)
- source
- (register-alias source false))))
- (delete-dead-registers!)
- (let ((target (if-not)))
- (prefix-instructions!
- (if alias
- (register->register-transfer alias target)
- (home->register-transfer source target)))
- (register-reference target))))))
-\f
-(define (add-pseudo-register-alias! register alias)
- (set! *register-map*
- (add-pseudo-register-alias *register-map* register alias))
- (need-register! alias))
-
-(define (clear-map!)
- (delete-dead-registers!)
- (let ((instructions (clear-map)))
- (set! *register-map* (empty-register-map))
- (set! *needed-registers* '())
- instructions))
-
-(define-integrable (clear-map)
- (clear-map-instructions *register-map*))
-
-(define (clear-registers! . registers)
- (if (null? registers)
- '()
- (let loop ((map *register-map*) (registers registers))
- (save-machine-register map (car registers)
- (lambda (map instructions)
- (let ((map (delete-machine-register map (car registers))))
- (if (null? (cdr registers))
- (begin (set! *register-map* map)
- instructions)
- (append! instructions (loop map (cdr registers))))))))))
-
-(define (save-machine-register! register)
- (let ((contents (machine-register-contents *register-map* register)))
- (if contents
- (save-pseudo-register! contents))))
-
-(define (save-pseudo-register! register)
- (if (not (dead-register? register))
- (save-pseudo-register *register-map* register
- (lambda (map instructions)
- (set! *register-map* map)
- (prefix-instructions! instructions)))))
-
-(define (delete-machine-register! register)
- (set! *register-map* (delete-machine-register *register-map* register))
- (set! *needed-registers* (eqv-set-delete *needed-registers* register)))
-
-(package (delete-pseudo-register! delete-dead-registers!)
- (define-export (delete-pseudo-register! register)
- (delete-pseudo-register *register-map* register delete-registers!))
- (define-export (delete-dead-registers!)
- (delete-pseudo-registers *register-map* *dead-registers* delete-registers!)
- (set! *dead-registers* '()))
- (define (delete-registers! map aliases)
- (set! *register-map* map)
- (set! *needed-registers* (eqv-set-difference *needed-registers* aliases))))
-\f
-(define *next-constant*)
-(define *interned-constants*)
-
-(define (constant->label constant)
- (let ((entry (assv constant *interned-constants*)))
- (if entry
- (cdr entry)
- (let ((label
- (string->symbol
- (string-append "CONSTANT-"
- (write-to-string *next-constant*)))))
- (set! *next-constant* (1+ *next-constant*))
- (set! *interned-constants*
- (cons (cons constant label)
- *interned-constants*))
- label))))
-
-(define-integrable (set-current-branches! consequent alternative)
- (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent)
- pattern)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.87 1987/03/19 00:50:25 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Register Allocator
-
-(declare (usual-integrations))
-\f
-#|
-
-The register allocator provides a mechanism for allocating and
-deallocating machine registers. It manages the available machine
-registers as a cache, by maintaining a ``map'' which records two kinds
-of information: (1) a list of the machine registers which are not in
-use; and (2) a mapping which is the association between the allocated
-machine registers and the ``pseudo registers'' which they represent.
-
-An ``alias'' is a machine register which also holds the contents of a
-pseudo register. Usually an alias is used for a short period of time,
-as a store-in cache, and then eventually the contents of the alias is
-written back out to the home it is associated with. Because of the
-lifetime analysis, it is possible to identify those registers which
-will no longer be referenced; these are deleted from the map when they
-die, and thus do not need to be saved.
-
-A ``temporary'' is a machine register with no associated home. It
-is used during the code generation of a single RTL instruction to
-hold intermediate results.
-
-Each pseudo register that has at least one alias has an entry in the
-map. While a home is entered in the map, it may have one or more
-aliases added or deleted to its entry, but if the number of aliases
-ever drops to zero, the entry is removed from the map.
-
-Each temporary has an entry in the map, with the difference being
-that the entry has no pseudo register associated with it. Thus it
-need never be written out.
-
-All registers, both machine and pseudo, are represented by
-non-negative integers. Machine registers start at zero (inclusive)
-and stop at NUMBER-OF-MACHINE-REGISTERS (exclusive). All others are
-pseudo registers. Because they are integers, we can use MEMV on lists
-of registers.
-
-AVAILABLE-MACHINE-REGISTERS should be a list of the registers which
-the allocator is allowed to allocate, in the preferred order of
-allocation.
-
-(SORT-MACHINE-REGISTERS REGISTERS) should reorder a list of machine
-registers into some interesting sorting order if that is desired.
-
-(PSEUDO-REGISTER=? X Y) is true iff X and Y are the ``same'' register.
-Normally, two pseudo registers are the same if their
-REGISTER-RENUMBERs are equal.
-
-|#
-\f
-(define empty-register-map)
-(define bind-allocator-values)
-
-(define load-alias-register)
-(define allocate-alias-register)
-(define allocate-temporary-register)
-(define add-pseudo-register-alias)
-
-(define machine-register-contents)
-(define pseudo-register-aliases)
-
-(define machine-register-alias)
-(define pseudo-register-alias)
-
-(define save-machine-register)
-(define save-pseudo-register)
-
-(define delete-machine-register)
-(define delete-pseudo-register)
-
-(define delete-pseudo-registers)
-(define delete-other-locations)
-
-(define coerce-map-instructions)
-(define clear-map-instructions)
-
-(define register-allocator-package
- (make-environment
-\f
-;;;; Register Map
-
-(define-integrable make-register-map cons)
-(define-integrable map-entries car)
-(define-integrable map-registers cdr)
-
-(define-export (empty-register-map)
- (make-register-map '() available-machine-registers))
-
-(define-integrable (map-entries:search map procedure)
- (set-search (map-entries map) procedure))
-
-(define (map-entries:find-home map pseudo-register)
- (map-entries:search map
- (lambda (entry)
- (let ((home (map-entry-home entry)))
- (and home
- (pseudo-register=? home pseudo-register)
- entry)))))
-
-(define (map-entries:find-alias map register)
- (map-entries:search map
- (lambda (entry)
- ;; **** Kludge -- depends on fact that machine registers are
- ;; fixnums, and thus EQ? works on them.
- (and (memq register (map-entry-aliases entry))
- entry))))
-
-(define-integrable (map-entries:add map entry)
- (cons entry (map-entries map)))
-
-(define-integrable (map-entries:delete map entry)
- (eq-set-delete (map-entries map) entry))
-
-(define-integrable (map-entries:delete* map entries)
- (eq-set-difference (map-entries map) entries))
-
-(define-integrable (map-entries:replace map old new)
- (eq-set-substitute (map-entries map) old new))
-
-(define-integrable (map-registers:add map register)
- (sort-machine-registers (cons register (map-registers map))))
-
-(define-integrable (map-registers:add* map registers)
- (sort-machine-registers (append registers (map-registers map))))
-
-(define-integrable (map-registers:delete map register)
- (eqv-set-delete (map-registers map) register))
-\f
-;;;; Map Entry
-
-(define-integrable (make-map-entry home saved-into-home? aliases)
- ;; HOME may be false, indicating that this is a temporary register.
- ;; SAVED-INTO-HOME? must be true when HOME is false. ALIASES must
- ;; be a non-null list of registers.
- (vector home saved-into-home? aliases))
-
-(define-integrable (map-entry-home entry)
- (vector-ref entry 0))
-
-(define-integrable (map-entry-saved-into-home? entry)
- (vector-ref entry 1))
-
-(define-integrable (map-entry-aliases entry)
- (vector-ref entry 2))
-
-(define-integrable (map-entry:any-alias entry)
- (car (map-entry-aliases entry)))
-
-(define (map-entry:add-alias entry alias)
- (make-map-entry (map-entry-home entry)
- (map-entry-saved-into-home? entry)
- (cons alias (map-entry-aliases entry))))
-
-(define (map-entry:delete-alias entry alias)
- (make-map-entry (map-entry-home entry)
- (map-entry-saved-into-home? entry)
- (eq-set-delete (map-entry-aliases entry) alias)))
-
-(define (map-entry=? entry entry*)
- (and (map-entry-home entry)
- (map-entry-home entry*)
- (pseudo-register=? (map-entry-home entry)
- (map-entry-home entry*))))
-\f
-;;;; Map Constructors
-
-;;; These constructors are responsible for maintaining consistency
-;;; between the map entries and available registers.
-
-(define (register-map:add-home map home alias)
- (make-register-map (map-entries:add map
- (make-map-entry home true (list alias)))
- (map-registers:delete map alias)))
-
-(define (register-map:add-alias map entry alias)
- (make-register-map (map-entries:replace map entry
- (map-entry:add-alias entry alias))
- (map-registers:delete map alias)))
-
-(define (register-map:save-entry map entry)
- (make-register-map
- (map-entries:replace map entry
- (make-map-entry (map-entry-home entry)
- true
- (map-entry-aliases entry)))
- (map-registers map)))
-
-(define (register-map:delete-entry map entry)
- (make-register-map (map-entries:delete map entry)
- (map-registers:add* map (map-entry-aliases entry))))
-
-(define (register-map:delete-entries regmap entries)
- (make-register-map (map-entries:delete* regmap entries)
- (map-registers:add* regmap
- (apply append
- (map map-entry-aliases
- entries)))))
-
-(define (register-map:delete-alias map entry alias)
- (make-register-map (if (null? (cdr (map-entry-aliases entry)))
- (map-entries:delete map entry)
- (map-entries:replace map entry
- (map-entry:delete-alias entry
- alias)))
- (map-registers:add map alias)))
-
-(define (register-map:delete-other-aliases map entry alias)
- (make-register-map (map-entries:replace map entry
- (let ((home (map-entry-home entry)))
- (make-map-entry home (not home)
- (list alias))))
- (map-registers:add* map
- ;; **** Kludge -- again, EQ? is
- ;; assumed to work on machine regs.
- (delq alias
- (map-entry-aliases entry)))))
-\f
-;;;; Register Allocator
-
-(define (make-free-register map type needed-registers)
- (define (reallocate-alias entry)
- (let ((alias (find-alias entry)))
- (and alias
- (delete-alias entry alias '()))))
-
- (define (find-alias entry)
- (list-search-positive (map-entry-aliases entry)
- (lambda (alias)
- (and (register-type? alias type)
- (not (memv alias needed-registers))))))
-
- (define (delete-alias entry alias instructions)
- (allocator-values alias
- (register-map:delete-alias map entry alias)
- instructions))
-
- (or
- ;; First see if there is an unused register of the given type.
- (let ((register (list-search-positive (map-registers map)
- (register-type-predicate type))))
- (and register
- (allocator-values register map '())))
- ;; There are no free registers available, so must reallocate one.
- ;; First look for a temporary register that is no longer needed.
- (map-entries:search map
- (lambda (entry)
- (and (not (map-entry-home entry))
- (reallocate-alias entry))))
- ;; Then look for a register which contains the same thing as
- ;; another register.
- (map-entries:search map
- (lambda (entry)
- (and (not (null? (cdr (map-entry-aliases entry))))
- (reallocate-alias entry))))
- ;; Look for a non-temporary which has been saved into its home.
- (map-entries:search map
- (lambda (entry)
- (and (map-entry-home entry)
- (map-entry-saved-into-home? entry)
- (reallocate-alias entry))))
- ;; Finally, save out a non-temporary and reallocate its register.
- (map-entries:search map
- (lambda (entry)
- (and (map-entry-home entry)
- (not (map-entry-saved-into-home? entry))
- (let ((alias (find-alias entry)))
- (and alias
- (delete-alias entry alias
- (save-into-home-instruction entry)))))))
- ;; Reaching this point indicates all registers are allocated.
- (error "MAKE-FREE-REGISTER: Unable to allocate register")))
-\f
-;;;; Allocator Operations
-
-(let ()
-
-(define-export (load-alias-register map type needed-registers home)
- ;; Finds or makes an alias register for HOME, and loads HOME's
- ;; contents into that register.
- (let ((entry (map-entries:find-home map home)))
- (or (use-existing-alias map entry type)
- (bind-allocator-values (make-free-register map type needed-registers)
- (lambda (alias map instructions)
- (if entry
- ;; MAKE-FREE-REGISTER will not flush ENTRY because it
- ;; has no aliases of the appropriate TYPE.
- (allocator-values
- alias
- (register-map:add-alias map entry alias)
- (append! instructions
- (register->register-transfer
- (map-entry:any-alias entry)
- alias)))
- (allocator-values
- alias
- (register-map:add-home map home alias)
- (append! instructions
- (home->register-transfer home alias)))))))))
-
-(define-export (allocate-alias-register map type needed-registers home)
- ;; Finds or makes an alias register for HOME. Used when about to
- ;; modify HOME's contents.
- (let ((entry (map-entries:find-home map home)))
- (or (use-existing-alias map entry type)
- (bind-allocator-values (make-free-register map type needed-registers)
- (lambda (alias map instructions)
- (allocator-values alias
- (if entry
- ;; MAKE-FREE-REGISTER will not flush
- ;; ENTRY because it has no aliases
- ;; of the appropriate TYPE.
- (register-map:add-alias map entry alias)
- (register-map:add-home map home alias))
- instructions))))))
-
-(define (use-existing-alias map entry type)
- (and entry
- (let ((alias (list-search-positive (map-entry-aliases entry)
- (register-type-predicate type))))
- (and alias
- (allocator-values alias map '())))))
-
-)
-\f
-(define-export (allocate-temporary-register map type needed-registers)
- (bind-allocator-values (make-free-register map type needed-registers)
- (lambda (alias map instructions)
- (allocator-values alias
- (register-map:add-home map false alias)
- instructions))))
-
-(define-export (add-pseudo-register-alias map register alias)
- (let ((entry (map-entries:find-home map register)))
- (if entry
- (register-map:add-alias map entry alias)
- (register-map:add-home map register alias))))
-
-(define-export (machine-register-contents map register)
- (let ((entry (map-entries:find-alias map register)))
- (and entry
- (map-entry-home entry))))
-
-(define-export (pseudo-register-aliases map register)
- (let ((entry (map-entries:find-home map register)))
- (and entry
- (map-entry-aliases entry))))
-
-(define-export (machine-register-alias map type register)
- (let ((entry (map-entries:find-alias map register)))
- (and entry
- (list-search-positive (map-entry-aliases entry)
- (lambda (register*)
- (and (not (eq? register register*))
- (register-type? type register*)))))))
-
-(define-export (pseudo-register-alias map type register)
- (let ((entry (map-entries:find-home map register)))
- (and entry
- (list-search-positive (map-entry-aliases entry)
- (register-type-predicate type)))))
-
-(define-export (save-machine-register map register receiver)
- (let ((entry (map-entries:find-alias map register)))
- (if (and entry
- (not (map-entry-saved-into-home? entry))
- (null? (cdr (map-entry-aliases entry))))
- (receiver (register-map:save-entry map entry)
- (save-into-home-instruction entry))
- (receiver map '()))))
-
-(define-export (save-pseudo-register map register receiver)
- (let ((entry (map-entries:find-home map register)))
- (if (and entry
- (not (map-entry-saved-into-home? entry)))
- (receiver (register-map:save-entry map entry)
- (save-into-home-instruction entry))
- (receiver map '()))))
-\f
-(define-export (delete-machine-register map register)
- (let ((entry (map-entries:find-alias map register)))
- (if entry
- (register-map:delete-alias map entry register)
- map)))
-
-(define-export (delete-pseudo-register map register receiver)
- (let ((entry (map-entries:find-home map register)))
- (if entry
- (receiver (register-map:delete-entry map entry)
- (map-entry-aliases entry))
- (receiver map '()))))
-
-(define-export (delete-pseudo-registers map registers receiver)
- ;; Used to remove dead registers from the map.
- (let loop ((registers registers)
- (receiver
- (lambda (entries aliases)
- (receiver (register-map:delete-entries map entries)
- aliases))))
- (if (null? registers)
- (receiver '() '())
- (loop (cdr registers)
- (let ((entry (map-entries:find-home map (car registers))))
- (if entry
- (lambda (entries aliases)
- (receiver (cons entry entries) aliases))
- receiver))))))
-
-(define-export (delete-other-locations map register)
- ;; Used in assignments to indicate that other locations containing
- ;; the same value no longer contain the value for a given home.
- (register-map:delete-other-aliases
- map
- (or (map-entries:find-alias map register)
- (error "DELETE-OTHER-LOCATIONS: Missing entry" register))
- register))
-
-(define-integrable (allocator-values alias map instructions)
- (vector alias map instructions))
-
-(define-export (bind-allocator-values values receiver)
- (receiver (vector-ref values 0)
- (vector-ref values 1)
- (vector-ref values 2)))
-
-(define (save-into-home-instruction entry)
- (register->home-transfer (map-entry:any-alias entry)
- (map-entry-home entry)))
-\f
-;;;; Map Coercion
-
-;;; These operations generate the instructions to coerce one map into
-;;; another. They are used when joining two branches of a control
-;;; flow graph which have different maps (e.g. in a loop.)
-
-(let ()
-
-(define-export (coerce-map-instructions input-map output-map)
- (three-way-sort map-entry=?
- (map-entries input-map)
- (map-entries output-map)
- (lambda (input-entries shared-entries output-entries)
- ((input-loop input-map
- ((shared-loop (output-loop (empty-register-map)
- output-entries))
- shared-entries))
- input-entries))))
-
-(define-export (clear-map-instructions input-map)
- ((input-loop input-map '()) (map-entries input-map)))
-
-(define (input-loop map tail)
- (define (loop entries)
- (if (null? entries)
- tail
- (let ((instructions (loop (cdr entries))))
- (if (map-entry-saved-into-home? (car entries))
- instructions
- (append! (save-into-home-instruction (car entries))
- instructions)))))
- loop)
-
-(define (shared-loop tail)
- (define (loop entries)
- (if (null? entries)
- tail
- (let ((input-aliases (map-entry-aliases (caar entries))))
- (define (loop output-aliases)
- (if (null? output-aliases)
- (shared-loop (cdr entries))
- (append! (register->register-transfer (car input-aliases)
- (car output-aliases))
- (loop (cdr output-aliases)))))
- (loop (eqv-set-difference (map-entry-aliases (cdar entries))
- input-aliases)))))
- loop)
-\f
-(define (output-loop map entries)
- (if (null? entries)
- '()
- (let ((instructions (output-loop map (cdr entries)))
- (home (map-entry-home (car entries))))
- (if home
- (let ((aliases (map-entry-aliases (car entries))))
- (define (loop registers)
- (if (null? registers)
- instructions
- (append! (register->register-transfer (car aliases)
- (car registers))
- (loop (cdr registers)))))
- (append! (home->register-transfer home (car aliases))
- (loop (cdr aliases))))
- instructions))))
-
-)
-
-;;; end REGISTER-ALLOCATOR-PACKAGE
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/symtab.scm,v 1.39 1987/03/19 00:50:36 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Symbol Tables
-
-(declare (usual-integrations))
-\f
-(define (make-symbol-table)
- (cons "Symbol Table" '()))
-
-(define (symbol-table-define! table key value)
- (let ((entry (assq key (cdr table))))
- (if entry
- (set-binding-value! (cdr entry) value)
- (set-cdr! table (cons (cons key (vector value '())) (cdr table))))))
-
-(define (symbol-table-binding table key)
- (let ((entry (assq key (cdr table))))
- (if entry
- (cdr entry)
- (let ((nothing (vector #F '())))
- (set-cdr! table (cons (cons key nothing) (cdr table)))
- nothing))))
-
-(define (symbol-table-value table key)
- (let ((entry (assq key (cdr table))))
- (or (and entry (vector-ref (cdr entry) 0))
- (error "SYMBOL-TABLE-VALUE: Undefined key" key))))
-
-(define (symbol-table-undefined-names table)
- (let loop ((entries (cdr table)))
- (cond ((null? entries) '())
- ((binding-value (cdr (car entries))) (loop (cdr entries)))
- (else (cons (car (car entries)) (loop (cdr entries)))))))
-
-(define-integrable (binding-value binding)
- (vector-ref binding 0))
-
-(define (set-binding-value! binding value)
- (if (vector-ref binding 0)
- (error "Attempt to redefine variable" binding))
- (vector-set! binding 0 value)
- (for-each (lambda (daemon) (daemon binding))
- (vector-ref binding 1)))
-
-(define (add-binding-daemon! binding daemon)
- (vector-set! binding 1 (cons daemon (vector-ref binding 1))))
-
-(define (remove-binding-daemon! binding daemon)
- (vector-set! binding 1 (delq! daemon (vector-ref binding 1))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.13 1987/03/19 00:50:43 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; LAP Syntaxer
-
-(declare (usual-integrations))
-\f
-(define (syntax-instructions instructions)
- (convert-output
- (let loop ((instructions instructions))
- (if (null? instructions)
- '()
- (append-syntax! (syntax-instruction (car instructions))
- (loop (cdr instructions)))))))
-
-(define (convert-output directives)
- (map (lambda (directive)
- (cond ((bit-string? directive) (vector 'CONSTANT directive))
- ((pair? directive)
- (if (eq? (car directive) 'GROUP)
- (vector 'GROUP (convert-output (cdr directive)))
- (list->vector directive)))
- ((vector? directive) directive)
- (else
- (error "SYNTAX-INSTRUCTIONS: Unknown directive" directive))))
- directives))
-
-(define (syntax-instruction instruction)
- (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
- (list instruction)
- (let ((match-result (instruction-lookup instruction)))
- (or (and match-result (match-result))
- (error "SYNTAX-INSTRUCTION: Badly formed instruction"
- instruction)))))
-
-(define (instruction-lookup instruction)
- (pattern-lookup
- (cdr (or (assq (car instruction) instructions)
- (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction))))
- (cdr instruction)))
-
-(define (add-instruction! keyword lookup)
- (let ((entry (assq keyword instructions)))
- (if entry
- (set-cdr! entry lookup)
- (set! instructions (cons (cons keyword lookup) instructions))))
- keyword)
-
-(define instructions
- '())
-
-(define (integer-syntaxer expression coercion-type size)
- (let ((coercion (make-coercion-name coercion-type size)))
- (if (integer? expression)
- `',((lexical-reference coercion-environment coercion) expression)
- `(SYNTAX-EVALUATION ,expression ,coercion))))
-\f
-(define (syntax-evaluation expression coercion)
- (if (integer? expression)
- (coercion expression)
- (vector 'EVALUATION expression (coercion-size coercion) coercion)))
-
-(define (cons-syntax directive directives)
- (if (and (bit-string? directive)
- (not (null? directives))
- (bit-string? (car directives)))
- (begin (set-car! directives
- (bit-string-append (car directives) directive))
- directives)
- (cons directive directives)))
-
-(define (append-syntax! directives directives*)
- (cond ((null? directives) directives*)
- ((null? directives*) directives)
- (else
- (let ((pair (last-pair directives)))
- (if (and (bit-string? (car pair))
- (bit-string? (car directives*)))
- (begin (set-car! pair
- (bit-string-append (car directives*)
- (car pair)))
- (set-cdr! pair (cdr directives*)))
- (set-cdr! pair directives*)))
- directives)))
-
-(define optimize-group
- (let ()
- (define (loop1 components)
- (cond ((null? components) '())
- ((bit-string? (car components))
- (loop2 (car components) (cdr components)))
- (else
- (cons (car components)
- (loop1 (cdr components))))))
-
- (define (loop2 bit-string components)
- (cond ((null? components)
- (list bit-string))
- ((bit-string? (car components))
- (loop2 (bit-string-append (car components) bit-string)
- (cdr components)))
- (else
- (cons bit-string
- (cons (car components)
- (loop1 (cdr components)))))))
-
- (lambda components
- (let ((components (loop1 components)))
- (cond ((null? components) (error "OPTIMIZE-GROUP: No components"))
- ((null? (cdr components)) (car components))
- (else `(GROUP ,@components)))))))
-\f
-;;;; Coercion Machinery
-
-(define (make-coercion-name coercion-type size)
- (string->symbol
- (string-append "COERCE-"
- (write-to-string size)
- "-BIT-"
- (write-to-string coercion-type))))
-
-(define coercion-property-tag
- "Coercion")
-
-(define ((coercion-maker coercion-types) coercion-type size)
- (let ((coercion
- ((cdr (or (assq coercion-type coercion-types)
- (error "Unknown coercion type" coercion-type)))
- size)))
- (2D-put! coercion coercion-property-tag (list coercion-type size))
- coercion))
-
-(define (coercion-size coercion)
- (cadr (coercion-properties coercion)))
-
-(define (unmake-coercion coercion receiver)
- (apply receiver (coercion-properties coercion)))
-
-(define (coercion-properties coercion)
- (or (2D-get coercion coercion-property-tag)
- (error "COERCION-PROPERTIES: Not a known coercion" coercion)))
-
-(define coercion-environment
- (the-environment))
-
-(define (define-coercion coercion-type size)
- (local-assignment coercion-environment
- (make-coercion-name coercion-type size)
- (make-coercion coercion-type size)))
-
-(define (lookup-coercion name)
- (lexical-reference coercion-environment name))
-\f
-(define ((coerce-unsigned-integer nbits) n)
- (unsigned-integer->bit-string nbits n))
-
-(define (coerce-signed-integer nbits)
- (let ((offset (expt 2 nbits)))
- (lambda (n)
- (unsigned-integer->bit-string nbits
- (if (negative? n)
- (+ n offset)
- n)))))
-
-(define (standard-coercion kernel)
- (lambda (nbits)
- (lambda (n)
- (unsigned-integer->bit-string nbits (kernel n)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.147 1987/03/19 00:32:34 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Control Flow Graph Abstraction
-
-(declare (usual-integrations))
-\f
-;;;; Node Datatypes
-
-(define cfg-node-tag (make-vector-tag false 'CFG-NODE))
-(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag))
-(define-vector-slots node 1 generation bblock alist previous-edges)
-
-(define-vector-method cfg-node-tag ':DESCRIBE
- (lambda (node)
- (descriptor-list node generation bblock alist previous-edges)))
-
-(define snode-tag (make-vector-tag cfg-node-tag 'SNODE))
-(define snode? (tagged-vector-subclass-predicate snode-tag))
-(define-vector-slots snode 5 next-edge)
-
-(define (make-snode tag . extra)
- (list->vector (cons* tag false false '() '() false extra)))
-
-(define-vector-method snode-tag ':DESCRIBE
- (lambda (snode)
- (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode)
- (descriptor-list snode next-edge))))
-
-(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE))
-(define pnode? (tagged-vector-subclass-predicate pnode-tag))
-(define-vector-slots pnode 5 consequent-edge alternative-edge)
-
-(define (make-pnode tag . extra)
- (list->vector (cons* tag false false '() '() false false extra)))
-
-(define-vector-method pnode-tag ':DESCRIBE
- (lambda (pnode)
- (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode)
- (descriptor-list pnode consequent-edge alternative-edge))))
-
-(define (edge-next-node edge)
- (and edge (edge-right-node edge)))
-
-(define-integrable (snode-next snode)
- (edge-next-node (snode-next-edge snode)))
-
-(define-integrable (pnode-consequent pnode)
- (edge-next-node (pnode-consequent-edge pnode)))
-
-(define-integrable (pnode-alternative pnode)
- (edge-next-node (pnode-alternative-edge pnode)))
-\f
-;;;; Edge Datatype
-
-(define-vector-slots edge 0 left-node left-connect right-node)
-
-(define-integrable (make-edge left-node left-connect right-node)
- (vector left-node left-connect right-node))
-
-(define (create-edge! left-node left-connect right-node)
- (let ((edge (make-edge left-node left-connect right-node)))
- (if left-node
- (left-connect left-node edge))
- (if right-node
- (let ((previous (node-previous-edges right-node)))
- (if (not (memq right-node previous))
- (set-node-previous-edges! right-node (cons edge previous)))))))
-
-(define (edge-connect-left! edge left-node left-connect)
- (set-edge-left-node! edge left-node)
- (set-edge-left-connect! edge left-connect)
- (if left-node
- (left-connect left-node edge)))
-
-(define (edge-connect-right! edge right-node)
- (set-edge-right-node! edge right-node)
- (if right-node
- (let ((previous (node-previous-edges right-node)))
- (if (not (memq right-node previous))
- (set-node-previous-edges! right-node (cons edge previous))))))
-
-(define (edges-connect-right! edges right-node)
- (for-each (lambda (edge)
- (edge-connect-right! edge right-node))
- edges))
-
-(define (edge-disconnect-left! edge)
- (let ((left-node (set-edge-left-node! edge false))
- (left-connect (set-edge-left-connect! edge false)))
- (if left-node
- (left-connect left-node false))))
-
-(define (edge-disconnect-right! edge)
- (let ((right-node (set-edge-right-node! edge false)))
- (if right-node
- (set-node-previous-edges! right-node
- (delq! edge
- (node-previous-edges right-node))))))
-
-(define (edge-disconnect! edge)
- (edge-disconnect-left! edge)
- (edge-disconnect-right! edge))
-
-(define (edges-disconnect-right! edges)
- (for-each edge-disconnect-right! edges))
-\f
-;;;; Editing
-
-;;; BBlock information is preserved only for deletions. Doing the
-;;; same for insertions is more difficult and not currently needed.
-
-(define (snode-delete! snode)
- (let ((bblock (node-bblock snode)))
- (if (and bblock
- (eq? snode (bblock-exit bblock))
- (not (eq? snode (bblock-entry bblock))))
- (set-bblock-exit! bblock (node-previous-first snode))))
- (let ((previous-edges (node-previous-edges snode))
- (next-edge (snode-next-edge snode)))
- (let ((node (edge-right-node next-edge)))
- (edges-disconnect-right! previous-edges)
- (edge-disconnect! next-edge)
- (edges-connect-right! previous-edges node))))
-
-(define (edge-insert-snode! edge snode)
- (let ((next (edge-right-node edge)))
- (edge-disconnect-right! edge)
- (edge-connect-right! edge snode)
- (create-edge! snode set-snode-next-edge! next)))
-
-(define (node-insert-snode! node snode)
- (let ((previous-edges (node-previous-edges node)))
- (edges-disconnect-right! previous-edges)
- (edges-connect-right! previous-edges snode)
- (create-edge! snode set-snode-next-edge! node)))
-
-(define (node->edge node)
- (let ((edge (make-edge false false false)))
- (edge-connect-right! edge node)
- edge))
-
-(define-integrable (cfg-entry-edge cfg)
- (node->edge (cfg-entry-node cfg)))
-\f
-;;;; Previous Connections
-
-(define-integrable (node-previous=0? node)
- (edges=0? (node-previous-edges node)))
-
-(define (edges=0? edges)
- (cond ((null? edges) true)
- ((edge-left-node (car edges)) false)
- (else (edges=0? (cdr edges)))))
-
-(define-integrable (node-previous>0? node)
- (edges>0? (node-previous-edges node)))
-
-(define (edges>0? edges)
- (cond ((null? edges) false)
- ((edge-left-node (car edges)) true)
- (else (edges>0? (cdr edges)))))
-
-(define-integrable (node-previous=1? node)
- (edges=1? (node-previous-edges node)))
-
-(define (edges=1? edges)
- (if (null? edges)
- false
- ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges))))
-
-(define-integrable (node-previous>1? node)
- (edges>1? (node-previous-edges node)))
-
-(define (edges>1? edges)
- (if (null? edges)
- false
- ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges))))
-
-(define-integrable (node-previous-first node)
- (edges-first-node (node-previous-edges node)))
-
-(define (edges-first-node edges)
- (if (null? edges)
- (error "No first hook")
- (or (edge-left-node (car edges))
- (edges-first-node (cdr edges)))))
-
-(define (for-each-previous-node node procedure)
- (for-each (lambda (edge)
- (let ((node (edge-left-node edge)))
- (if node
- (procedure node))))
- (node-previous-edges node)))
-\f
-;;;; Noops
-
-(define noop-node-tag (make-vector-tag snode-tag 'NOOP))
-(define *noop-nodes*)
-
-(define-integrable (make-noop-node)
- (let ((node (make-snode noop-node-tag)))
- (set! *noop-nodes* (cons node *noop-nodes*))
- node))
-
-(define (delete-noop-nodes!)
- (for-each snode-delete! *noop-nodes*)
- (set! *noop-nodes* '()))
-
-(define (constant->pcfg value)
- ((if value make-true-pcfg make-false-pcfg)))
-
-(define (make-false-pcfg)
- (let ((node (make-noop-node)))
- (make-pcfg node
- '()
- (list (make-hook node set-snode-next-edge!)))))
-
-(define (make-true-pcfg)
- (let ((node (make-noop-node)))
- (make-pcfg node
- (list (make-hook node set-snode-next-edge!))
- '())))
-\f
-;;;; Miscellaneous
-
-(package (with-new-node-marks
- node-marked?
- node-mark!)
-
-(define *generation*)
-
-(define-export (with-new-node-marks thunk)
- (fluid-let ((*generation* (make-generation)))
- (thunk)))
-
-(define make-generation
- (let ((generation 0))
- (named-lambda (make-generation)
- (let ((value generation))
- (set! generation (1+ generation))
- value))))
-
-(define-export (node-marked? node)
- (eq? (node-generation node) *generation*))
-
-(define-export (node-mark! node)
- (set-node-generation! node *generation*))
-
-)
-
-(define (node-property-get node key)
- (let ((entry (assq key (node-alist node))))
- (and entry (cdr entry))))
-
-(define (node-property-put! node key item)
- (let ((entry (assq key (node-alist node))))
- (if entry
- (set-cdr! entry item)
- (set-node-alist! node (cons (cons key item) (node-alist node))))))
-
-(define (node-property-remove! node key)
- (set-node-alist! node (del-assq! key (node-alist node))))
-
-(define (node-label node)
- (or (node-labelled? node)
- (let ((label (generate-label)))
- (set-node-label! node label)
- label)))
-
-(define-integrable (node-labelled? node)
- (node-property-get node node-label))
-
-(define-integrable (set-node-label! node label)
- (node-property-put! node node-label label))
-\f
-;;;; CFG Datatypes
-
-;;; A CFG is a compound CFG-node, so there are different types of CFG
-;;; corresponding to the (connective-wise) different types of
-;;; CFG-node. One may insert a particular type of CFG anywhere in a
-;;; graph that its corresponding node may be inserted.
-
-(define-integrable (make-scfg node next-hooks)
- (vector 'SNODE-CFG node next-hooks))
-
-(define-integrable (make-scfg* node consequent-hooks alternative-hooks)
- (make-scfg node (hooks-union consequent-hooks alternative-hooks)))
-
-(define-integrable (make-pcfg node consequent-hooks alternative-hooks)
- (vector 'PNODE-CFG node consequent-hooks alternative-hooks))
-
-(define-integrable (cfg-tag cfg)
- (vector-ref cfg 0))
-
-(define-integrable (cfg-entry-node cfg)
- (vector-ref cfg 1))
-
-(define-integrable (scfg-next-hooks scfg)
- (vector-ref scfg 2))
-
-(define-integrable (pcfg-consequent-hooks pcfg)
- (vector-ref pcfg 2))
-
-(define-integrable (pcfg-alternative-hooks pcfg)
- (vector-ref pcfg 3))
-
-(define-integrable (make-null-cfg) false)
-(define-integrable cfg-null? false?)
-
-(define-integrable (snode->scfg snode)
- (node->scfg snode set-snode-next-edge!))
-
-(define (node->scfg node set-node-next!)
- (make-scfg node
- (list (make-hook node set-node-next!))))
-
-(define-integrable (pnode->pcfg pnode)
- (node->pcfg pnode
- set-pnode-consequent-edge!
- set-pnode-alternative-edge!))
-
-(define (node->pcfg node set-node-consequent! set-node-alternative!)
- (make-pcfg node
- (list (make-hook node set-node-consequent!))
- (list (make-hook node set-node-alternative!))))
-\f
-;;;; Hook Datatype
-
-(define-integrable make-hook cons)
-(define-integrable hook-node car)
-(define-integrable hook-connect cdr)
-
-(define (hook=? x y)
- (and (eq? (hook-node x) (hook-node y))
- (eq? (hook-connect x) (hook-connect y))))
-
-(define hook-member?
- (member-procedure hook=?))
-
-(define (hooks-union x y)
- (let loop ((x x))
- (cond ((null? x) y)
- ((hook-member? (car x) y) (loop (cdr x)))
- (else (cons (car x) (loop (cdr x)))))))
-
-(define (hooks-connect! hooks node)
- (for-each (lambda (hook)
- (hook-connect! hook node))
- hooks))
-
-(define (hook-connect! hook node)
- (create-edge! (hook-node hook) (hook-connect hook) node))
-
-(define (scfg*node->node! scfg next-node)
- (if (cfg-null? scfg)
- next-node
- (begin (if next-node
- (hooks-connect! (scfg-next-hooks scfg) next-node))
- (cfg-entry-node scfg))))
-
-(define (pcfg*node->node! pcfg consequent-node alternative-node)
- (if (cfg-null? pcfg)
- (error "PCFG*NODE->NODE!: Can't have null predicate"))
- (if consequent-node
- (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node))
- (if alternative-node
- (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node))
- (cfg-entry-node pcfg))
-\f
-;;;; CFG Construction
-
-(define-integrable (scfg-next-connect! scfg cfg)
- (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg)))
-
-(define-integrable (pcfg-consequent-connect! pcfg cfg)
- (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg)))
-
-(define-integrable (pcfg-alternative-connect! pcfg cfg)
- (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg)))
-
-(define (scfg*scfg->scfg! scfg scfg*)
- (cond ((not scfg) scfg*)
- ((not scfg*) scfg)
- (else
- (scfg-next-connect! scfg scfg*)
- (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
-
-(package (scfg-append! scfg*->scfg!)
-
-(define-export (scfg-append! . scfgs)
- (scfg*->scfg! scfgs))
-
-(define-export (scfg*->scfg! scfgs)
- (let ((first (find-non-null scfgs)))
- (and (not (null? first))
- (let ((second (find-non-null (cdr first))))
- (if (null? second)
- (car first)
- (make-scfg (cfg-entry-node (car first))
- (scfg-next-hooks
- (loop (car first)
- (car second)
- (find-non-null (cdr second))))))))))
-
-(define (loop first second third)
- (scfg-next-connect! first second)
- (if (null? third)
- second
- (loop second (car third) (find-non-null (cdr third)))))
-
-(define (find-non-null scfgs)
- (if (or (null? scfgs)
- (car scfgs))
- scfgs
- (find-non-null (cdr scfgs))))
-
-)
-\f
-(define (pcfg->scfg! pcfg)
- (make-scfg* (cfg-entry-node pcfg)
- (pcfg-consequent-hooks pcfg)
- (pcfg-alternative-hooks pcfg)))
-
-(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!)
-
-(define ((scfg*pcfg->cfg! transformer constructor) scfg pcfg)
- (cond ((not pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate"))
- ((not scfg) (transformer pcfg))
- (else
- (scfg-next-connect! scfg pcfg)
- (constructor (cfg-entry-node scfg)
- (pcfg-consequent-hooks pcfg)
- (pcfg-alternative-hooks pcfg)))))
-
-(define scfg*pcfg->pcfg!
- (scfg*pcfg->cfg! identity-procedure make-pcfg))
-
-(define scfg*pcfg->scfg!
- (scfg*pcfg->cfg! pcfg->scfg! make-scfg*))
-
-)
-
-(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!)
-
-(define ((pcfg*scfg->cfg! transformer constructor) pcfg consequent alternative)
- (cond ((not pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate"))
- ((not consequent)
- (if (not alternative)
- (transformer pcfg)
- (begin (pcfg-alternative-connect! pcfg alternative)
- (constructor (cfg-entry-node pcfg)
- (pcfg-consequent-hooks pcfg)
- (scfg-next-hooks alternative)))))
- ((not alternative)
- (pcfg-consequent-connect! pcfg consequent)
- (constructor (cfg-entry-node pcfg)
- (scfg-next-hooks consequent)
- (pcfg-alternative-hooks pcfg)))
- (else
- (pcfg-consequent-connect! pcfg consequent)
- (pcfg-alternative-connect! pcfg alternative)
- (constructor (cfg-entry-node pcfg)
- (scfg-next-hooks consequent)
- (scfg-next-hooks alternative)))))
-
-(define pcfg*scfg->pcfg!
- (pcfg*scfg->cfg! identity-procedure make-pcfg))
-
-(define pcfg*scfg->scfg!
- (pcfg*scfg->cfg! pcfg->scfg! make-scfg*))
-
-)
-\f
-(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!)
-
-(define ((pcfg*pcfg->cfg! transformer constructor) pcfg consequent alternative)
- (cond ((not pcfg)
- (error "PCFG*PCFG->CFG!: Can't have null predicate"))
- ((not consequent)
- (if (not alternative)
- (transformer pcfg)
- (begin (pcfg-alternative-connect! pcfg alternative)
- (constructor
- (cfg-entry-node pcfg)
- (hooks-union (pcfg-consequent-hooks pcfg)
- (pcfg-consequent-hooks alternative))
- (pcfg-alternative-hooks alternative)))))
- ((not alternative)
- (pcfg-consequent-connect! pcfg consequent)
- (constructor (cfg-entry-node pcfg)
- (pcfg-consequent-hooks consequent)
- (hooks-union (pcfg-alternative-hooks consequent)
- (pcfg-alternative-hooks pcfg))))
- (else
- (pcfg-consequent-connect! pcfg consequent)
- (pcfg-alternative-connect! pcfg alternative)
- (constructor (cfg-entry-node pcfg)
- (hooks-union (pcfg-consequent-hooks consequent)
- (pcfg-consequent-hooks alternative))
- (hooks-union (pcfg-alternative-hooks consequent)
- (pcfg-alternative-hooks alternative))))))
-
-(define pcfg*pcfg->pcfg!
- (pcfg*pcfg->cfg! identity-procedure make-pcfg))
-
-(define pcfg*pcfg->scfg!
- (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*))
-
- (for-each edge-disconnect-right! edges))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.42 1987/03/19 23:11:10 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler CFG Datatypes
-
-(declare (usual-integrations))
-\f
-(define-snode assignment block lvalue rvalue)
-
-(define (make-assignment block lvalue rvalue)
- (vnode-connect! lvalue rvalue)
- (if (variable? lvalue)
- (set-variable-assignments! lvalue (1+ (variable-assignments lvalue))))
- (snode->scfg (make-snode assignment-tag block lvalue rvalue)))
-
-(define-snode definition block lvalue rvalue)
-
-(define (make-definition block lvalue rvalue)
- (vnode-connect! lvalue rvalue)
- (if (variable? lvalue)
- (set-variable-assignments! lvalue (1+ (variable-assignments lvalue))))
- (snode->scfg (make-snode definition-tag block lvalue rvalue)))
-
-(define-pnode true-test rvalue)
-
-(define-integrable (make-true-test rvalue)
- (pnode->pcfg (make-pnode true-test-tag rvalue)))
-
-(define-pnode unassigned-test block variable)
-
-(define-integrable (make-unassigned-test block variable)
- (pnode->pcfg (make-pnode unassigned-test-tag block variable)))
-
-(define-pnode unbound-test block variable)
-
-(define-integrable (make-unbound-test block variable)
- (pnode->pcfg (make-pnode unbound-test-tag block variable)))
-\f
-(define-snode combination block compilation-type value operator operands
- procedures known-operator)
-(define *combinations*)
-
-(define (make-combination block compilation-type value operator operands)
- (let ((combination
- (make-snode combination-tag block compilation-type value operator
- operands '() false)))
- (set! *combinations* (cons combination *combinations*))
- (set-block-combinations! block
- (cons combination (block-combinations block)))
- (set-vnode-combinations! value
- (cons combination (vnode-combinations value)))
- (snode->scfg combination)))
-
-(define-snode continuation rtl-edge delta label)
-(define *continuations*)
-
-(define-integrable (make-continuation delta)
- (let ((continuation
- (make-snode continuation-tag false delta
- (generate-label 'CONTINUATION))))
- (set! *continuations* (cons continuation *continuations*))
- continuation))
-
-(define-integrable (continuation-rtl-entry continuation)
- (edge-right-node (continuation-rtl-edge continuation)))
-
-(define-integrable (set-continuation-rtl-entry! continuation node)
- (set-continuation-rtl-edge! continuation (node->edge node)))
-
-(define-unparser continuation-tag
- (lambda (continuation)
- (symbol-hash-table/lookup *label->object* label))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.56 1987/03/19 00:33:44 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler Macros
-
-(declare (usual-integrations))
-\f
-(define compiler-syntax-table
- (make-syntax-table system-global-syntax-table))
-
-(define lap-generator-syntax-table
- (make-syntax-table compiler-syntax-table))
-
-(define assembler-syntax-table
- (make-syntax-table compiler-syntax-table))
-
-(syntax-table-define compiler-syntax-table 'PACKAGE
- (in-package system-global-environment
- (declare (usual-integrations))
- (lambda (expression)
- (apply (lambda (names . body)
- (make-sequence
- `(,@(map (lambda (name)
- (make-definition name (make-unassigned-object)))
- names)
- ,(make-combination
- (let ((block (syntax* body)))
- (if (open-block? block)
- (open-block-components block
- (lambda (names* declarations body)
- (make-lambda lambda-tag:let '() '() false
- (list-transform-negative names*
- (lambda (name)
- (memq name names)))
- declarations
- body)))
- (make-lambda lambda-tag:let '() '() false '()
- '() block)))
- '()))))
- (cdr expression)))))
-\f
-(let ()
-
-(define (parse-define-syntax pattern body if-variable if-lambda)
- (cond ((pair? pattern)
- (let loop ((pattern pattern) (body body))
- (cond ((pair? (car pattern))
- (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
- ((symbol? (car pattern))
- (if-lambda pattern body))
- (else
- (error "Illegal name" parse-define-syntax (car pattern))))))
- ((symbol? pattern)
- (if-variable pattern body))
- (else
- (error "Illegal name" parse-define-syntax pattern))))
-
-(define lambda-list->bound-names
- (let ((accumulate
- (lambda (lambda-list)
- (cons (let ((parameter (car lambda-list)))
- (if (pair? parameter) (car parameter) parameter))
- (lambda-list->bound-names (cdr lambda-list))))))
- (named-lambda (lambda-list->bound-names lambda-list)
- (cond ((symbol? lambda-list)
- lambda-list)
- ((null? lambda-list) '())
- ((not (pair? lambda-list))
- (error "Illegal rest variable" lambda-list))
- ((eq? (car lambda-list)
- (access lambda-optional-tag lambda-package))
- (if (pair? (cdr lambda-list))
- (accumulate (cdr lambda-list))
- (error "Missing optional variable" lambda-list)))
- (else
- (accumulate lambda-list))))))
-\f
-(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT
- (macro (pattern . body)
- (parse-define-syntax pattern body
- (lambda (name body)
- `(SET! ,pattern ,@body))
- (lambda (pattern body)
- `(SET! ,(car pattern)
- (NAMED-LAMBDA ,pattern ,@body))))))
-
-(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE
- (macro (pattern . body)
-#|
- (parse-define-syntax pattern body
- (lambda (name body)
- `(BEGIN (DECLARE (INTEGRATE ,pattern))
- (DEFINE ,pattern ,@body)))
- (lambda (pattern body)
- `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,(car pattern)))
- (DEFINE ,pattern
- ,@(if (list? (cdr pattern))
- `(DECLARE
- (INTEGRATE
- ,@(lambda-list->bound-names (cdr pattern))))
- '())
- ,@body))))
-|#
- `(DEFINE ,pattern ,@body)))
-
-)
-\f
-(syntax-table-define compiler-syntax-table 'DEFINE-VECTOR-SLOTS
- (macro (class index . slots)
- (define (loop slots n)
- (if (null? slots)
- '()
- (cons (let ((ref-name (symbol-append class '- (car slots))))
- `(BEGIN
- (DEFINE-INTEGRABLE (,ref-name ,class)
- (VECTOR-REF ,class ,n))
- (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
- ,class ,(car slots))
- (VECTOR-SET! ,class ,n ,(car slots)))))
- (loop (cdr slots) (1+ n)))))
- (if (null? slots)
- '*THE-NON-PRINTING-OBJECT*
- `(BEGIN ,@(loop slots index)))))
-
-(let-syntax
- ((define-type-definition
- (macro (name reserved)
- (let ((parent (symbol-append name '-TAG)))
- `(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE
- ',(symbol-append 'DEFINE- name)
- (macro (type . slots)
- (let ((tag-name (symbol-append type '-TAG)))
- `(BEGIN (DEFINE ,tag-name
- (MAKE-VECTOR-TAG ,',parent ',type))
- (DEFINE ,(symbol-append type '?)
- (TAGGED-VECTOR-PREDICATE ,tag-name))
- (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
- (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE
- (LAMBDA (,type)
- (APPEND!
- ((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type)
- (DESCRIPTOR-LIST ,type ,@slots))))))))))))
- (define-type-definition snode 6)
- (define-type-definition pnode 7)
- (define-type-definition rvalue 1)
- (define-type-definition vnode 10))
-
-(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST
- (macro (type . slots)
- `(LIST ,@(map (lambda (slot)
- (let ((ref-name (symbol-append type '- slot)))
- ``(,',ref-name ,(,ref-name ,type))))
- slots))))
-\f
-(let ((rtl-common
- (lambda (type prefix components wrap-constructor)
- `(BEGIN
- (DEFINE-INTEGRABLE (,(symbol-append prefix 'MAKE- type) . REST)
- ,(wrap-constructor `(CONS ',type REST)))
- (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
- (EQ? (CAR EXPRESSION) ',type))
- ,@(let loop ((components components)
- (ref-index 6)
- (set-index 2))
- (if (null? components)
- '()
- (let* ((slot (car components))
- (name (symbol-append type '- slot)))
- `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
- (GENERAL-CAR-CDR ,type ,ref-index))
- (DEFINE-INTEGRABLE (,(symbol-append 'RTL:SET- name '!)
- ,type ,slot)
- (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index) ,slot))
- ,@(loop (cdr components)
- (* ref-index 2)
- (* set-index 2))))))))))
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-EXPRESSION
- (macro (type prefix . components)
- (rtl-common type prefix components identity-procedure)))
-
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT
- (macro (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(STATEMENT->SCFG ,expression)))))
-
- (syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE
- (macro (type prefix . components)
- (rtl-common type prefix components
- (lambda (expression) `(PREDICATE->PCFG ,expression))))))
-\f
-(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES
- (macro (slot)
- (let ((name (symbol-append 'REGISTER- slot)))
- (let ((vector (symbol-append '* name '*)))
- `(BEGIN (DEFINE ,vector)
- (DEFINE-INTEGRABLE (,name REGISTER)
- (VECTOR-REF ,vector REGISTER))
- (DEFINE-INTEGRABLE
- (,(symbol-append 'SET- name '!) REGISTER VALUE)
- (VECTOR-SET! ,vector REGISTER VALUE)))))))
-
-(syntax-table-define compiler-syntax-table 'UCODE-TYPE
- (macro (name)
- (microcode-type name)))
-
-(syntax-table-define compiler-syntax-table 'UCODE-PRIMITIVE
- (macro (name)
- (make-primitive-procedure name)))
-
-(syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
- (macro (type pattern . body)
- (parse-rule pattern body
- (lambda (pattern names transformer qualifier actions)
- `(,(case type
- ((STATEMENT) 'ADD-STATEMENT-RULE!)
- ((PREDICATE) 'ADD-STATEMENT-RULE!)
- (else (error "Unknown rule type" type)))
- ',pattern
- ,(rule-result-expression names transformer qualifier
- `(BEGIN ,@actions)))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/mvalue.scm,v 3.0 1987/03/10 13:25:05 cph Rel $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Multiple Value Support
-
-(declare (usual-integrations))
-\f
-(define (transmit-values transmitter receiver)
- (transmitter receiver))
-
-(define (multiple-value-list transmitter)
- (transmitter list))
-
-(define (return . values)
- (lambda (receiver)
- (apply receiver values)))
-
-;;; For efficiency:
-
-(define (return-2 v0 v1)
- (lambda (receiver)
- (receiver v0 v1)))
-
-(define (return-3 v0 v1 v2)
- (lambda (receiver)
- (receiver v0 v1 v2)))
-
-(define (return-4 v0 v1 v2 v3)
- (lambda (receiver)
- (receiver v0 v1 v2 v3)))
-
-(define (return-5 v0 v1 v2 v3 v4)
- (lambda (receiver)
- (receiver v0 v1 v2 v3 v4)))
-
-(define (return-6 v0 v1 v2 v3 v4 v5)
- (lambda (receiver)
- (receiver v0 v1 v2 v3 v4 v5)))
-
-(define (list-multiple first . rest)
- (apply call-multiple list first rest))
-
-(define (cons-multiple cars cdrs)
- (call-multiple cons cars cdrs))
-
-(define (call-multiple procedure . transmitters)
- (apply return
- (apply map
- procedure
- (map multiple-value-list transmitters))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 1.1 1987/03/19 00:44:29 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Support for tagged objects
-
-(declare (usual-integrations))
-\f
-(define (make-vector-tag parent name)
- (let ((tag (cons '() (or parent vector-tag:object))))
- (vector-tag-put! tag ':TYPE-NAME name)
- ((access add-unparser-special-object! unparser-package)
- tag tagged-vector-unparser)
- tag))
-
-(define *tagged-vector-unparser-show-hash*
- true)
-
-(define (tagged-vector-unparser object)
- (unparse-with-brackets
- (lambda ()
- (write-string "LIAR ")
- (if *tagged-vector-unparser-show-hash*
- (begin (fluid-let ((*unparser-radix* 10))
- (write (hash object)))
- (write-string " ")))
- (fluid-let ((*unparser-radix* 16))
- ((vector-method object ':UNPARSE) object)))))
-
-(define (vector-tag-put! tag key value)
- (let ((entry (assq key (car tag))))
- (if entry
- (set-cdr! entry value)
- (set-car! tag (cons (cons key value) (car tag))))))
-
-(define (vector-tag-get tag key)
- (define (loop tag)
- (and (pair? tag)
- (or (assq key (car tag))
- (loop (cdr tag)))))
- (let ((value
- (or (assq key (car tag))
- (loop (cdr tag)))))
- (and value (cdr value))))
-
-(define vector-tag:object
- (list '()))
-
-(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT)
-
-(define-integrable (vector-tag vector)
- (vector-ref vector 0))
-
-(define (define-vector-method tag name method)
- (vector-tag-put! tag name method)
- name)
-
-(define (vector-tag-method tag name)
- (or (vector-tag-get tag name)
- (error "Unbound method" tag name)))
-\f
-(define-integrable (vector-tag-parent-method tag name)
- (vector-tag-method (cdr tag) name))
-
-(define-integrable (vector-method vector name)
- (vector-tag-method (vector-tag vector) name))
-
-(define (define-unparser tag unparser)
- (define-vector-method tag ':UNPARSE unparser))
-
-(define-integrable make-tagged-vector
- vector)
-
-(define ((tagged-vector-predicate tag) object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? tag (vector-tag object))))
-
-(define (tagged-vector-subclass-predicate tag)
- (define (loop tag*)
- (or (eq? tag tag*)
- (and (pair? tag*)
- (loop (cdr tag*)))))
- (lambda (object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (loop (vector-tag object)))))
-
-(define tagged-vector?
- (tagged-vector-subclass-predicate vector-tag:object))
-
-(define-unparser vector-tag:object
- (lambda (object)
- (write (vector-method object ':TYPE-NAME))))
-
-(define (->tagged-vector object)
- (or (and (tagged-vector? object) object)
- (and (integer? object)
- (let ((object (unhash object)))
- (and (tagged-vector? object) object)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/pmlook.scm,v 1.1 1987/04/17 07:59:56 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Very Simple Pattern Matcher: Lookup
-
-(declare (usual-integrations))
-\f
-(package (pattern-lookup pattern-variables make-pattern-variable)
-
-;;; PATTERN-LOOKUP returns either false or a pair whose car is the
-;;; item matched and whose cdr is the list of variable values. Use
-;;; PATTERN-VARIABLES to get a list of names that is in the same order
-;;; as the list of values.
-
-(define (pattern-lookup entries instance)
- (define (lookup-loop entries values)
- (define (match pattern instance)
- (if (pair? pattern)
- (if (eq? (car pattern) pattern-variable-tag)
- (let ((entry (memq (cdr pattern) values)))
- (if entry
- (eqv? (cdr entry) instance)
- (begin (set! values (cons instance values))
- true)))
- (and (pair? instance)
- (match (car pattern) (car instance))
- (match (cdr pattern) (cdr instance))))
- (eqv? pattern instance)))
- (and (not (null? entries))
- (or (and (match (caar entries) instance)
- (apply (cdar entries) values))
- (lookup-loop (cdr entries) '()))))
- (lookup-loop entries '()))
-
-(define (pattern-variables pattern)
- (let ((variables '()))
- (define (loop pattern)
- (if (pair? pattern)
- (if (eq? (car pattern) pattern-variable-tag)
- (if (not (memq (cdr pattern) variables))
- (set! variables (cons (cdr pattern) variables)))
- (begin (loop (car pattern))
- (loop (cdr pattern))))))
- (loop pattern)
- variables))
-
-(define (make-pattern-variable name)
- (cons pattern-variable-tag name))
-
-(define pattern-variable-tag
- (make-named-tag "Pattern Variable"))
-
-)
-
-;;; ALL-TRUE? is used to determine if splicing variables with
-;;; qualifiers satisfy the qualification.
-
-(define (all-true? values)
- (or (null? values)
- (and (car values)
- (all-true? (cdr values)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 1.1 1987/03/19 00:44:43 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Simple Set Abstraction
-
-(declare (usual-integrations))
-\f
-(define (eq-set-adjoin element set)
- (if (memq element set)
- set
- (cons element set)))
-
-(define (eqv-set-adjoin element set)
- (if (memv element set)
- set
- (cons element set)))
-
-(define (eq-set-delete set item)
- (define (loop set)
- (cond ((null? set) '())
- ((eq? (car set) item) (cdr set))
- (else (cons (car set) (loop (cdr set))))))
- (loop set))
-
-(define (eqv-set-delete set item)
- (define (loop set)
- (cond ((null? set) '())
- ((eqv? (car set) item) (cdr set))
- (else (cons (car set) (loop (cdr set))))))
- (loop set))
-
-(define (eq-set-substitute set old new)
- (define (loop set)
- (cond ((null? set) '())
- ((eq? (car set) old) (cons new (cdr set)))
- (else (cons (car set) (loop (cdr set))))))
- (loop set))
-
-(define (eqv-set-substitute set old new)
- (define (loop set)
- (cond ((null? set) '())
- ((eqv? (car set) old) (cons new (cdr set)))
- (else (cons (car set) (loop (cdr set))))))
- (loop set))
-
-(define (set-search set procedure)
- (define (loop items)
- (and (not (null? items))
- (or (procedure (car items))
- (loop (cdr items)))))
- (loop set))
-\f
-;;; The dataflow analyzer assumes that
-;;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
-
-(define (eq-set-union x y)
- (if (null? y)
- x
- (let loop ((x x) (y y))
- (if (null? x)
- y
- (loop (cdr x)
- (if (memq (car x) y)
- y
- (cons (car x) y)))))))
-
-(define (eqv-set-union x y)
- (if (null? y)
- x
- (let loop ((x x) (y y))
- (if (null? x)
- y
- (loop (cdr x)
- (if (memv (car x) y)
- y
- (cons (car x) y)))))))
-
-(define (eq-set-difference x y)
- (define (loop x)
- (cond ((null? x) '())
- ((memq (car x) y) (loop (cdr x)))
- (else (cons (car x) (loop (cdr x))))))
- (loop x))
-
-(define (eqv-set-difference x y)
- (define (loop x)
- (cond ((null? x) '())
- ((memv (car x) y) (loop (cdr x)))
- (else (cons (car x) (loop (cdr x))))))
- (loop x))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.85 1987/04/17 07:38:02 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler Utilities
-
-(declare (usual-integrations))
-\f
-;;;; Miscellaneous
-
-(define (three-way-sort = set set* receiver)
- (let ((member? (member-procedure =)))
- (define (loop set set* receiver)
- (if (null? set)
- (receiver '() '() set*)
- (let ((item (member? (car set) set*)))
- (if item
- (loop (cdr set) (delq! (car item) set*)
- (lambda (set-only both set*-only)
- (receiver set-only
- (cons (cons (car set) (car item)) both)
- set*-only)))
- (loop (cdr set) set*
- (lambda (set-only both set*-only)
- (receiver (cons (car set) set-only)
- both
- set*-only)))))))
- (loop set (list-copy set*) receiver)))
-
-(define (generate-label #!optional prefix)
- (if (unassigned? prefix) (set! prefix 'LABEL))
- (string->symbol
- (string-append
- (symbol->string
- (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA)
- ((eq? prefix lambda-tag:let) 'LET)
- ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT)
- ((or (eq? prefix lambda-tag:shallow-fluid-let)
- (eq? prefix lambda-tag:deep-fluid-let)
- (eq? prefix lambda-tag:common-lisp-fluid-let))
- 'FLUID-LET)
- (else prefix)))
- "-"
- (write-to-string (generate-label-number)))))
-
-(define *current-label-number*)
-
-(define (generate-label-number)
- (let ((number *current-label-number*))
- (set! *current-label-number* (1+ *current-label-number*))
- number))
-\f
-(define (copy-alist alist)
- (if (null? alist)
- '()
- (cons (cons (caar alist) (cdar alist))
- (copy-alist (cdr alist)))))
-
-(define (warn message . irritants)
- (newline)
- (write-string "Warning: ")
- (write-string message)
- (for-each (lambda (irritant)
- (write-string " ")
- (write irritant))
- irritants))
-
-(define (show-time thunk)
- (let ((start (runtime)))
- (let ((value (thunk)))
- (write-line (- (runtime) start))
- value)))
-\f
-;;;; SCode Interface
-
-(let-syntax ((define-scode-operator
- (macro (name)
- `(DEFINE ,(symbol-append 'SCODE/ name)
- (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))))
- (define-scode-operator access-components)
- (define-scode-operator access?)
- (define-scode-operator assignment?)
- (define-scode-operator assignment-components)
- (define-scode-operator assignment-name)
- (define-scode-operator assignment-value)
- (define-scode-operator combination-components)
- (define-scode-operator combination?)
- (define-scode-operator comment-expression)
- (define-scode-operator comment?)
- (define-scode-operator conditional-components)
- (define-scode-operator definition-components)
- (define-scode-operator delay?)
- (define-scode-operator delay-expression)
- (define-scode-operator disjunction-components)
- (define-scode-operator in-package-components)
- (define-scode-operator lambda-components)
- (define-scode-operator lambda?)
- (define-scode-operator make-access)
- (define-scode-operator make-assignment)
- (define-scode-operator make-combination)
- (define-scode-operator make-conditional)
- (define-scode-operator make-definition)
- (define-scode-operator make-lambda)
- (define-scode-operator make-quotation)
- (define-scode-operator make-sequence)
- (define-scode-operator make-variable)
- (define-scode-operator open-block-components)
- (define-scode-operator open-block?)
- (define-scode-operator primitive-procedure?)
- (define-scode-operator procedure?)
- (define-scode-operator quotation-expression)
- (define-scode-operator sequence-actions)
- (define-scode-operator unassigned-object?)
- (define-scode-operator unassigned?-name)
- (define-scode-operator unbound?-name)
- (define-scode-operator variable-name)
- (define-scode-operator variable?))
-
-(define scode/constant?
- (access scode-constant? system-global-environment))
-\f
-(define (scode/error-combination-components combination receiver)
- (scode/combination-components combination
- (lambda (operator operands)
- (receiver (car operands)
- (let ((irritant (cadr operands)))
- (cond ((scode/access? irritant) '())
- ((scode/combination? irritant)
- (scode/combination-components irritant
- (lambda (operator operands)
- (if (and (scode/access? operator)
- (scode/access-components operator
- (lambda (environment name)
- (and (null? environment)
- (eq? name 'LIST)))))
- operands
- (list irritant)))))
- (else (list irritant))))))))
-
-(define (scode/procedure-type-code *lambda)
- (cond ((primitive-type? type-code:lambda *lambda)
- type-code:procedure)
- ((primitive-type? type-code:extended-lambda *lambda)
- type-code:extended-procedure)
- (else
- (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
-
-(define (scode/make-let names values body)
- (scode/make-combination (scode/make-lambda lambda-tag:let names '() false '()
- '() body)
- values))
-\f
-;;;; Type Codes
-
-(define type-code:lambda
- (microcode-type 'LAMBDA))
-
-(define type-code:extended-lambda
- (microcode-type 'EXTENDED-LAMBDA))
-
-(define type-code:procedure
- (microcode-type 'PROCEDURE))
-
-(define type-code:extended-procedure
- (microcode-type 'EXTENDED-PROCEDURE))
-
-(define type-code:cell
- (microcode-type 'CELL))
-
-(define type-code:compiled-expression
- (microcode-type 'COMPILED-EXPRESSION))
-
-(define type-code:compiler-link
- (microcode-type 'COMPILER-LINK))
-
-(define type-code:compiled-procedure
- (microcode-type 'COMPILED-PROCEDURE))
-
-(define type-code:environment
- (microcode-type 'ENVIRONMENT))
-
-(define type-code:stack-environment
- (microcode-type 'STACK-ENVIRONMENT))
-
-(define type-code:return-address
- (microcode-type 'COMPILER-RETURN-ADDRESS))
-
-(define type-code:unassigned
- (microcode-type 'UNASSIGNED))
-\f
-;;; Disgusting hack to replace microcode implementation.
-
-(define (primitive-procedure-safe? object)
- (and (primitive-type? (ucode-type primitive) object)
- (not (memq object
- (let-syntax ((primitives
- (macro names
- `'(,@(map make-primitive-procedure names)))))
- (primitives call-with-current-continuation
- non-reentrant-call-with-current-continuation
- scode-eval
- apply
- garbage-collect
- primitive-fasdump
- set-current-history!
- with-history-disabled
- force
- primitive-purify
- complete-garbage-collect
- dump-band
- primitive-impurify
- with-threaded-continuation
- within-control-point
- with-interrupts-reduced
- primitive-eval-step
- primitive-apply-step
- primitive-return-step
- execute-at-new-state-point
- translate-to-state-point
- with-interrupt-mask
- error-procedure))))))
-\f
-;;;; Special Compiler Support
-
-(define compiled-error-procedure
- "Compiled error procedure")
-
-(define lambda-tag:delay
- (make-named-tag "DELAY-LAMBDA"))
-
-(define (non-pointer-object? object)
- (or (primitive-type? (ucode-type false) object)
- (primitive-type? (ucode-type true) object)
- (primitive-type? (ucode-type fixnum) object)
- (primitive-type? (ucode-type character) object)
- (primitive-type? (ucode-type unassigned) object)
- (primitive-type? (ucode-type primitive) object)
- (primitive-type? (ucode-type the-environment) object)
- (primitive-type? (ucode-type manifest-nm-vector) object)
- (primitive-type? (ucode-type manifest-special-nm-vector) object)))
-
-(define (object-immutable? object)
- (or (non-pointer-object? object)
- (number? object)
- (symbol? object)
- (scode/primitive-procedure? object)
- (eq? object compiled-error-procedure)))
-
-(define (operator-constant-foldable? operator)
- (memq operator constant-foldable-operators))
-
-(define constant-foldable-operators
- (list primitive-type primitive-type?
- eq? null? pair? car cdr vector-length vector-ref
- number? complex? real? rational? integer?
- zero? positive? negative? odd? even? exact? inexact?
- = < > <= >= max min
- + - * / 1+ -1+ abs quotient remainder modulo integer-divide
- gcd lcm floor ceiling truncate round
- exp log expt sqrt sin cos tan asin acos atan
- (ucode-primitive &+) (ucode-primitive &-)
- (ucode-primitive &*) (ucode-primitive &/)
- (ucode-primitive &<) (ucode-primitive &>)
- (ucode-primitive &=) (ucode-primitive &atan)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/assmd.scm,v 1.29 1987/03/19 00:52:27 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(define addressing-granularity 8)
-(define scheme-object-width 32)
-
-(define make-nmv-header)
-(let ()
-
-(set! make-nmv-header
-(named-lambda (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string 24 n)
- nmv-type-string)))
-
-(define nmv-type-string
- (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))
-
-)
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string 24 (primitive-datum object))
- (unsigned-integer->bit-string 8 (primitive-type object))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/coerce.scm,v 1.7 1987/03/19 00:52:34 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; 68000 Specific Coercions
-
-(declare (usual-integrations))
-\f
-(define coerce-quick
- (standard-coercion
- (lambda (n)
- (cond ((< 0 n 8) n)
- ((= n 8) 0)
- (else (error "Bad quick immediate" n))))))
-
-(define coerce-short-label
- (standard-coercion
- (lambda (offset)
- (or (if (negative? offset)
- (and (>= offset -128) (+ offset 256))
- (and (< offset 128) offset))
- (error "Short label out of range" offset)))))
-
-(define make-coercion
- (coercion-maker
- `((UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer)
- (QUICK . ,coerce-quick)
- (SHIFT-NUMBER . ,coerce-quick)
- (SHORT-LABEL . ,coerce-short-label))))
-
-(define-coercion 'UNSIGNED 1)
-(define-coercion 'UNSIGNED 2)
-(define-coercion 'UNSIGNED 3)
-(define-coercion 'UNSIGNED 4)
-(define-coercion 'UNSIGNED 5)
-(define-coercion 'UNSIGNED 6)
-(define-coercion 'UNSIGNED 8)
-(define-coercion 'UNSIGNED 9)
-(define-coercion 'UNSIGNED 10)
-(define-coercion 'UNSIGNED 12)
-(define-coercion 'UNSIGNED 13)
-(define-coercion 'UNSIGNED 16)
-(define-coercion 'UNSIGNED 32)
-
-(define-coercion 'SIGNED 8)
-(define-coercion 'SIGNED 16)
-(define-coercion 'SIGNED 32)
-
-(define-coercion 'QUICK 3)
-(define-coercion 'SHIFT-NUMBER 3)
-(define-coercion 'SHORT-LABEL 8)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.1 1987/03/19 00:44:26 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler File Dependencies
-
-(declare (usual-integrations))
-\f
-(define (file-dependency/integration/chain filenames)
- (if (not (null? (cdr filenames)))
- (begin (file-dependency/integration/make (car filenames) (cdr filenames))
- (file-dependency/integration/chain (cdr filenames)))))
-
-(define (file-dependency/integration/join filenames dependency)
- (for-each (lambda (filename)
- (file-dependency/integration/make filename dependency))
- filenames))
-
-(define (file-dependency/integration/make filename dependency)
-#|
- (sf/add-file-declarations! filename `((INTEGRATE-EXTERNAL ,@dependency)))
-|#
- 'DONE)
-
-(define (filename/append directory . names)
- (map (lambda (name)
- (string-append directory "/" name))
- names))
-
-(define (file-dependency/syntax/join filenames dependency)
- (for-each (lambda (filename)
- (sf/set-file-syntax-table! filename dependency))
- filenames))
-\f
-(define filenames/dependency-chain/base
- (filename/append "base"
- "object" "cfg" "ctypes" "dtypes" "bblock" "dfg" "rtltyp"
- "rtlreg" "rtlcfg" "rtl" "emodel" "rtypes"))
-
-(define filenames/dependency-chain/rcse
- (filename/append "front-end" "rcseht" "rcserq" "rcsesr" "rcseep" "rcse"))
-
-(define filenames/dependency-group/base
- (append (filename/append "base" "linear")
- (filename/append "alpha" "dflow" "graphc")
- (filename/append "front-end"
- "ralloc" "rcsesa" "rgcomb" "rlife" "rtlgen")
- (filename/append "back-end" "lapgen")))
-
-(file-dependency/integration/chain
- (reverse
- (append filenames/dependency-chain/base
- filenames/dependency-chain/rcse)))
-
-(file-dependency/integration/join filenames/dependency-group/base
- filenames/dependency-chain/base)
-
-(file-dependency/syntax/join
- (append (filename/append "base"
- "bblock" "cfg" "ctypes" "dfg" "dtypes" "emodel"
- "linear" "object" "queue" "rtl" "rtlcfg" "rtlreg"
- "rtltyp" "rtypes" "sets" "toplev" "utils")
- (filename/append "alpha" "dflow" "graphc")
- (filename/append "front-end"
- "ralloc" "rcse" "rcseep" "rcseht" "rcserq" "rcsesa"
- "rcsesr" "rgcomb" "rlife" "rtlgen")
- (filename/append "back-end"
- "asmmac" "block" "lapgen" "laptop" "regmap" "symtab")
- (filename/append "machines/bobcat" "insmac" "machin"))
- compiler-syntax-table)
-
-(file-dependency/syntax/join
- (append (filename/append "machines/bobcat" "lapgen")
- (filename/append "machines/spectrum" "lapgen"))
- lap-generator-syntax-table)
-
-(file-dependency/syntax/join
- (append (filename/append "machines/bobcat" "instr1" "instr2" "instr3")
- (filename/append "machines/spectrum" "instrs"))
- assembler-syntax-table)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.118 1987/03/19 00:52:58 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; 68000 Instruction Set Macros
-
-(declare (usual-integrations))
-\f
-;;;; Instruction Definitions
-
-(syntax-table-define assembler-syntax-table 'MAKE-EA-DATABASE
- (macro rules
- (compile-database rules
- (lambda (pattern actions)
- (let ((keyword (car pattern))
- (categories (car actions))
- (mode (cadr actions))
- (register (caddr actions))
- (extension (cdddr actions)))
- ;;(declare (integrate keyword categories mode register extension))
- `(MAKE-EFFECTIVE-ADDRESS
- ',keyword
- (LAMBDA () ,(integer-syntaxer mode 'UNSIGNED 3))
- (LAMBDA () ,(integer-syntaxer register 'UNSIGNED 3))
- (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
- ,(if (null? extension)
- 'INSTRUCTION-TAIL
- `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL)))
- ',categories))))))
-
-(syntax-table-define assembler-syntax-table 'EXTENSION-WORD
- (macro descriptors
- (expand-descriptors descriptors
- (lambda (instruction size source destination)
- (if (or source destination)
- (error "Source or destination used" 'EXTENSION-WORD)
- (if (zero? (remainder size 16))
- (apply optimize-group-syntax instruction)
- (error "EXTENSION-WORD: Extensions must be 16 bit multiples"
- size)))))))
-\f
-(define (parse-word expression tail)
- (expand-descriptors (cdr expression)
- (lambda (instruction size src dst)
- (if (zero? (remainder size 16))
- (let ((code
- (let ((code
- (let ((code (if dst `(,@dst '()) '())))
- (if src
- `(,@src ,code)
- code))))
- (if (null? tail)
- code
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(car tail)
- ,code)))))
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(apply optimize-group-syntax instruction)
- ,code))
- (error "PARSE-WORD: Instructions must be 16 bit multiples" size)))))
-
-(define (expand-descriptors descriptors receiver)
- (if (null? descriptors)
- (receiver '() 0 false false)
- (expand-descriptors (cdr descriptors)
- (lambda (instruction* size* source* destination*)
- (expand-descriptor (car descriptors)
- (lambda (instruction size source destination)
- (receiver (append! instruction instruction*)
- (+ size size*)
- (if source
- (if source*
- (error "Multiple source definitions"
- 'EXPAND-DESCRIPTORS)
- source)
- source*)
- (if destination
- (if destination*
- (error "Multiple destination definitions"
- 'EXPAND-DESCRIPTORS)
- destination)
- destination*))))))))
-\f
-(define (expand-descriptor descriptor receiver)
- (let ((size (car descriptor))
- (expression (cadr descriptor))
- (coercion-type
- (if (null? (cddr descriptor)) 'UNSIGNED (caddr descriptor))))
- (case coercion-type
- ((UNSIGNED SIGNED SHIFT-NUMBER QUICK)
- (receiver `(,(integer-syntaxer expression coercion-type size))
- size false false))
- ((SHORT-LABEL)
- (receiver `(,(integer-syntaxer
- ``(- ,,expression (+ *PC* 2))
- 'SHORT-LABEL
- size))
- size false false))
- ((SOURCE-EA)
- (receiver `(((EA-MODE ,expression))
- ((EA-REGISTER ,expression)))
- size
- `((EA-EXTENSION ,expression) ,(cadddr descriptor))
- false))
- ((DESTINATION-EA)
- (receiver `(((EA-MODE ,expression))
- ((EA-REGISTER ,expression)))
- size
- false
- `((EA-EXTENSION ,expression) '())))
- ((DESTINATION-EA-REVERSED)
- (receiver `(((EA-REGISTER ,expression))
- ((EA-MODE ,expression)))
- size
- false
- `((EA-EXTENSION ,expression) '())))
- (else
- (error "EXPAND-DESCRIPTOR: Badly-formed descriptor" descriptor)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.60 1987/03/19 00:53:05 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;;; Effective Addressing
-
-(define (make-effective-address keyword mode register extension categories)
- (vector ea-tag keyword mode register extension categories))
-
-(define (effective-address? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) ea-tag)))
-
-(define ea-tag
- "Effective-Address")
-
-(define-integrable (ea-keyword ea)
- (vector-ref ea 1))
-
-(define-integrable (ea-mode ea)
- (vector-ref ea 2))
-
-(define-integrable (ea-register ea)
- (vector-ref ea 3))
-
-(define-integrable (ea-extension ea)
- (vector-ref ea 4))
-
-(define-integrable (ea-categories ea)
- (vector-ref ea 5))
-\f
-(define (ea-all expression)
- (let ((match-result (pattern-lookup ea-database expression)))
- (and match-result (match-result))))
-
-(define ((ea-filtered filter) expression)
- (let ((ea (ea-all expression)))
- (and ea (filter ea) ea)))
-
-(define (ea-filtered-by-category category)
- (ea-filtered
- (lambda (ea)
- (memq category (ea-categories ea)))))
-
-(define ea-d (ea-filtered-by-category 'DATA))
-(define ea-a (ea-filtered-by-category 'ALTERABLE))
-(define ea-c (ea-filtered-by-category 'CONTROL))
-
-(define (ea-filtered-by-categories categories)
- (ea-filtered
- (lambda (ea)
- (eq?-subset? categories (ea-categories ea)))))
-
-(define (eq?-subset? x y)
- (or (null? x)
- (and (memq (car x) y)
- (eq?-subset? (cdr x) y))))
-
-(define ea-d&a (ea-filtered-by-categories '(DATA ALTERABLE)))
-(define ea-c&a (ea-filtered-by-categories '(CONTROL ALTERABLE)))
-(define ea-m&a (ea-filtered-by-categories '(MEMORY ALTERABLE)))
-
-(define ea-d&-&
- (ea-filtered
- (lambda (ea)
- (and (not (eq? (ea-keyword ea) '&))
- (memq 'DATA (ea-categories ea))))))
-
-;;; These are just predicates, to be used in conjunction with EA-ALL.
-
-(define (ea-b=>-A ea s)
- (not (and (eq? s 'B) (eq? (ea-keyword ea) 'A))))
-
-(define (ea-a&<b=>-A> ea s)
- (and (memq 'ALTERABLE (ea-categories ea)) (ea-b=>-A ea s)))
-\f
-;;;; Effective Address Description
-
-(define ea-database
- (make-ea-database
- ((D (? r)) (DATA ALTERABLE) #b000 r)
-
- ((A (? r)) (ALTERABLE) #b001 r)
-
- ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r)
-
- ((@D (? r))
- (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
- (output-@D-indirect r))
-
- ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r)
-
- ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r)
-
- ((@AO (? r) (? o))
- (DATA MEMORY CONTROL ALTERABLE) #b101 r
- (output-16bit-offset o))
-
- ((@AR (? r) (? l))
- (DATA MEMORY CONTROL ALTERABLE) #b101 r
- (output-16bit-relative l))
-
- ((@DO (? r) (? o))
- (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
- (output-@DO-indirect r o))
-\f
- ((@AOX (? r) (? o) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-offset-index-register xtype xr s o))
-
- ((@ARX (? r) (? l) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-relative-index-register xtype xr s l))
-
- ((W (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b000
- (output-16bit-address a))
-
- ((L (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b001
- (output-32bit-address a))
-
- ((@PCO (? o))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-offset o))
-
- ((@PCR (? l))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-relative l))
-
- ((@PCOX (? o) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-offset-index-register xtype xr s o))
-
- ((@PCRX (? l) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-relative-index-register xtype xr s l))
-
- ((& (? i))
- (DATA MEMORY) #b111 #b100
- (output-immediate-data immediate-size i))))
-\f
-;;;; Effective Address Extensions
-
-(define-integrable (output-16bit-offset o)
- (EXTENSION-WORD (16 o SIGNED)))
-
-(define-integrable (output-16bit-relative l)
- (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-offset-index-register xtype xr s o)
- (EXTENSION-WORD (1 (encode-da xtype))
- (3 xr)
- (1 (encode-wl s))
- (3 #b000)
- (8 o SIGNED)))
-
-(define-integrable (output-relative-index-register xtype xr s l)
- (EXTENSION-WORD (1 (encode-da xtype))
- (3 xr)
- (1 (encode-wl s))
- (3 #b000)
- (8 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-16bit-address a)
- (EXTENSION-WORD (16 a)))
-
-(define-integrable (output-32bit-address a)
- (EXTENSION-WORD (32 a)))
-
-(define (output-immediate-data immediate-size i)
- (case immediate-size
- ((B)
- (EXTENSION-WORD (8 #b00000000)
- (8 i SIGNED)))
- ((W)
- (EXTENSION-WORD (16 i SIGNED)))
- ((L)
- (EXTENSION-WORD (32 i SIGNED)))
- (else
- (error "OUTPUT-IMMEDIATE-DATA: illegal immediate size"
- immediate-size))))
-\f
-;;; New stuff for 68020
-
-(define (output-brief-format-extension-word immediate-size
- index-register-type index-register
- index-size scale-factor
- displacement)
- (EXTENSION-WORD (1 (encode-da index-register-type))
- (3 index-register)
- (1 (encode-wl index-size))
- (2 (encode-bwlq scale-factor))
- (1 #b0)
- (8 displacement SIGNED)))
-
-(define (output-full-format-extension-word immediate-size
- index-register-type index-register
- index-size scale-factor
- base-suppress? index-suppress?
- base-displacement-size
- base-displacement
- memory-indirection-type
- outer-displacement-size
- outer-displacement)
- (EXTENSION-WORD (1 (encode-da index-register-type))
- (3 index-register)
- (1 (encode-wl index-size))
- (2 (encode-bwlq scale-factor))
- (1 #b1)
- (1 (if base-suppress? #b1 #b0))
- (1 (if index-suppress? #b1 #b0))
- (2 (encode-nwl base-displacement-size))
- (1 #b0)
- (3 (case memory-indirection-type
- ((#F) #b000)
- ((PRE) (encode-nwl outer-displacement-size))
- ((POST)
- (+ #b100 (encode-nwl outer-displacement-size))))))
- (output-displacement base-displacement-size base-displacement)
- (output-displacement outer-displacement-size outer-displacement))
-
-(define (output-displacement size displacement)
- (case size
- ((N))
- ((W) (EXTENSION-WORD (16 displacement SIGNED)))
- ((L) (EXTENSION-WORD (32 displacement SIGNED)))))
-\f
-(define-integrable (output-@D-indirect register)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = longword
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b01) ;null base displacement
- (1 #b0)
- (3 #b000) ;no memory indirection
- ))
-
-(define (output-@DO-indirect register displacement)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = 32 bits
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b10) ;base displacement size = 16 bits
- (1 #b0)
- (3 #b000) ;no memory indirection
- (16 displacement SIGNED)))
-\f
-;;;; Operand Syntaxers.
-
-(define (immediate-words data size)
- (case size
- ((B) (immediate-byte data))
- ((W) (immediate-word data))
- ((L) (immediate-long data))
- (else (error "IMMEDIATE-WORD: Illegal size" size))))
-
-(define-integrable (immediate-byte data)
- `(GROUP ,(make-bit-string 8 0)
- ,(syntax-evaluation data coerce-8-bit-signed)))
-
-(define-integrable (immediate-word data)
- (syntax-evaluation data coerce-16-bit-signed))
-
-(define-integrable (immediate-long data)
- (syntax-evaluation data coerce-32-bit-signed))
-
-(define-integrable (relative-word address)
- (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed))
-
-(define-integrable (offset-word data)
- (syntax-evaluation data coerce-16-bit-signed))
-
-(define-integrable (output-bit-string bit-string)
- bit-string)
-\f
-;;;; Symbolic Constants
-
-;(declare (integrate symbol-member bwl? bw? wl? rl? us? da? cc? nwl? bwlq?))
-
-(define ((symbol-member list) expression)
-; (declare (integrate list expression))
- (memq expression list))
-
-(define bwl? (symbol-member '(B W L)))
-(define bw? (symbol-member '(B W)))
-(define wl? (symbol-member '(W L)))
-(define rl? (symbol-member '(R L)))
-(define us? (symbol-member '(U S)))
-(define da? (symbol-member '(D A)))
-(define nwl? (symbol-member '(N W L)))
-(define bwlq? (symbol-member '(B W L Q)))
-
-(define cc?
- (symbol-member
- '(T F HI LS HS LO CC CS NE EQ VC VS PL MI GE LT GT LE)))
-
-;(declare (integrate symbol-mapping encode-bwl encode-blw encode-bw encode-wl
-; encode-lw encode-rl encode-us encode-da granularity
-; encode-cc encode-nwl encode-bwlq))
-
-(define ((symbol-mapping alist) expression)
-; (declare (integrate alist expression))
- (cdr (assq expression alist)))
-
-(define encode-bwl (symbol-mapping '((B . 0) (W . 1) (L . 2))))
-(define encode-blw (symbol-mapping '((B . 1) (W . 3) (L . 2))))
-(define encode-bw (symbol-mapping '((B . 0) (W . 1))))
-(define encode-wl (symbol-mapping '((W . 0) (L . 1))))
-(define encode-lw (symbol-mapping '((W . 1) (L . 0))))
-(define encode-rl (symbol-mapping '((R . 0) (L . 1))))
-(define encode-us (symbol-mapping '((U . 0) (S . 1))))
-(define encode-da (symbol-mapping '((D . 0) (A . 1))))
-(define granularity (symbol-mapping '((B . 8) (W . 16) (L . 32))))
-(define encode-nwl (symbol-mapping '((N . 1) (W . 2) (L . 3))))
-(define encode-bwlq (symbol-mapping '((B . 0) (W . 1) (L . 2) (Q . 3))))
-
-(define encode-cc
- (symbol-mapping
- '((T . 0) (F . 1) (HI . 2) (LS . 3) (HS . 4) (LO . 5)
- (CC . 4) (CS . 5) (NE . 6) (EQ . 7) (VC . 8) (VS . 9)
- (PL . 10) (MI . 11) (GE . 12) (LT . 13) (GT . 14) (LE . 15))))
-\f
-(define (register-list? expression)
- (eq?-subset? expression '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7)))
-
-(define ((encode-register-list encoding) registers)
- (let ((bit-string (make-bit-string 16 #!FALSE)))
- (for-each (lambda (register)
- (bit-string-set! bit-string (cdr (assq register encoding))))
- registers)
- bit-string))
-
-(define encode-c@a+register-list
- (encode-register-list
- '((A7 . 0) (A6 . 1) (A5 . 2) (A4 . 3) (A3 . 4) (A2 . 5) (A1 . 6) (A0 . 7)
- (D7 . 8) (D6 . 9) (D5 . 10) (D4 . 11) (D3 . 12) (D2 . 13)
- (D1 . 14) (D0 . 15))))
-
-(define encode-@-aregister-list
- (encode-register-list
- '((D0 . 0) (D1 . 1) (D2 . 2) (D3 . 3) (D4 . 4) (D5 . 5) (D6 . 6) (D7 . 7)
- (A0 . 8) (A1 . 9) (A2 . 10) (A3 . 11) (A4 . 12) (A5 . 13)
- (A6 . 14) (A7 . 15))))
-
-(define-instruction DC
- ((W (? expression))
- (WORD (16 expression SIGNED))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.9 1987/03/19 00:53:15 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;;; BCD Arithmetic
-
-(let-syntax ((define-BCD-addition
- (macro (keyword opcode)
- `(define-instruction ,keyword
- (((D (? ry)) (D (? rx)))
- (WORD (4 ,opcode)
- (3 rx)
- (6 #b100000)
- (3 ry)))
-
- (((@-A (? ry)) (@-A (? rx)))
- (WORD (4 ,opcode)
- (3 rx)
- (6 #b100001)
- (3 ry)))))))
- (define-BCD-addition ABCD #b1100)
- (define-BCD-addition SBCD #b1000))
-
-(define-instruction NBCD
- ((? dea ea-d&a)
- (WORD (10 #b0100100000)
- (6 dea DESTINATION-EA))))
-\f
-;;;; Binary Arithmetic
-
-(let-syntax ((define-binary-addition
- (macro (keyword Qkeyword Xkeyword opcode Qbit Iopcode)
- `(BEGIN
- (define-instruction ,Qkeyword
- (((? s) (& (? data)) (? ea ea-all))
- (QUALIFIER (bwl? s) (ea-a&<b=>-A> ea s))
- (WORD (4 #b0101)
- (3 data QUICK)
- (1 ,Qbit)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))))
-
- (define-instruction ,keyword
- (((? s) (& (? data)) (? ea ea-d&a)) ;ADDI
- (QUALIFIER (bwl? s))
- (WORD (4 #b0000)
- (4 ,Iopcode)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))
- (immediate-words data s))
-
- (((? s) (? ea ea-all) (D (? rx)))
- (QUALIFIER (bwl? s) (ea-b=>-A ea s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b0)
- (2 (encode-bwl s))
- (6 ea SOURCE-EA s)))
-
- (((? s) (D (? rx)) (? ea ea-m&a))
- (QUALIFIER (bwl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA)))
-
- (((? s) (? ea ea-all) (A (? rx))) ;ADDA
- (QUALIFIER (wl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 (encode-wl s))
- (2 #b11)
- (6 ea SOURCE-EA s))))
-
- (define-instruction ,Xkeyword
- (((? s) (D (? ry)) (D (? rx)))
- (QUALIFIER (bwl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (3 #b000)
- (3 ry)))
-
- (((? s) (@-A (? ry)) (@-A (? rx)))
- (QUALIFIER (bwl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (3 #b001)
- (3 ry))))))))
- (define-binary-addition ADD ADDQ ADDX #b1101 #b0 #b0110)
- (define-binary-addition SUB SUBQ SUBX #b1001 #b1 #b0100))
-\f
-(define-instruction DIV
- (((? sgn) (D (? rx)) (? ea ea-d))
- (QUALIFIER (us? sgn))
- (WORD (4 #b1000)
- (3 rx)
- (1 (encode-us sgn))
- (2 #b11)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction EXT
- (((? s) (D (? rx)))
- (QUALIFIER (wl? s))
- (WORD (9 #b010010001)
- (1 (encode-wl s))
- (3 #b000)
- (3 rx))))
-
-(define-instruction MUL
- (((? sgn) (? ea ea-d) (D (? rx)))
- (QUALIFIER (us? sgn))
- (WORD (4 #b1100)
- (3 rx)
- (1 (encode-us sgn))
- (2 #b11)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction NEG
- (((? s) (? dea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (8 #b01000100)
- (2 (encode-bwl s))
- (6 dea DESTINATION-EA))))
-
-(define-instruction NEGX
- (((? s) (? dea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (8 #b01000000)
- (2 (encode-bwl s))
- (6 dea DESTINATION-EA))))
-\f
-;;;; Comparisons
-
-(define-instruction CMP
- (((? s) (? ea ea-all) (D (? rx)))
- (QUALIFIER (bwl? s) (ea-b=>-A ea s))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b0)
- (2 (encode-bwl s))
- (6 ea SOURCE-EA s)))
-
- (((? s) (? ea ea-all) (A (? rx))) ;CMPA
- (QUALIFIER (wl? s))
- (WORD (4 #b1011)
- (3 rx)
- (1 (encode-wl s))
- (2 #b11)
- (6 ea SOURCE-EA s)))
-
- (((? s) (& (? data)) (? ea ea-d&a)) ;CMPI
- (QUALIFIER (bwl? s))
- (WORD (8 #b00001100)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))
- (immediate-words data s))
-
- (((? s) (@A+ (? ry)) (@A+ (? rx))) ;CMPM
- (QUALIFIER (bwl? s))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (3 #b001)
- (3 ry))))
-
-(define-instruction TST
- (((? s) (? dea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (8 #b01001010)
- (2 (encode-bwl s))
- (6 dea DESTINATION-EA))))
-\f
-;;;; Bitwise Logical
-
-(let-syntax ((define-bitwise-logical
- (macro (keyword opcode Iopcode)
- `(define-instruction ,keyword
- (((? s) (? ea ea-d) (D (? rx)))
- (QUALIFIER (bwl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b0)
- (2 (encode-bwl s))
- (6 ea SOURCE-EA s)))
-
- (((? s) (D (? rx)) (? ea ea-m&a))
- (QUALIFIER (bwl? s))
- (WORD (4 ,opcode)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA)))
-
- (((? s) (& (? data)) (? ea ea-d&a)) ;fooI
- (QUALIFIER (bwl? s))
- (WORD (4 #b0000)
- (4 ,Iopcode)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))
- (immediate-words data s))
-
- (((? s) (& (? data)) (SR)) ;fooI to CCR/SR
- (QUALIFIER (bw? s))
- (WORD (4 #b0000)
- (4 ,Iopcode)
- (2 (encode-bwl s))
- (6 #b111100))
- (immediate-words data s))))))
- (define-bitwise-logical AND #b1100 #b0010)
- (define-bitwise-logical OR #b1000 #b0000))
-
-(define-instruction EOR
- (((? s) (D (? rx)) (? ea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (4 #b1011)
- (3 rx)
- (1 #b1)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA)))
-
- (((? s) (& (? data)) (? ea ea-d&a)) ;EORI
- (QUALIFIER (bwl? s))
- (WORD (8 #b00001010)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))
- (immediate-words data s))
-
- (((? s) (& (? data)) (SR)) ;EORI to CCR/SR
- (QUALIFIER (bw? s))
- (WORD (8 #b00001010)
- (2 (encode-bwl s))
- (6 #b111100))
- (immediate-words data s)))
-
-(define-instruction NOT
- (((? s) (? dea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (8 #b01000110)
- (2 (encode-bwl s))
- (6 dea DESTINATION-EA))))
-\f
-;;;; Shift
-
-(let-syntax ((define-shift-instruction
- (macro (keyword bits)
- `(define-instruction ,keyword
- (((? d) (? s) (D (? ry)) (D (? rx)))
- (QUALIFIER (rl? d) (bwl? s))
- (WORD (4 #b1110)
- (3 rx)
- (1 (encode-rl d))
- (2 (encode-bwl s))
- (1 #b1)
- (2 ,bits)
- (3 ry)))
-
- (((? d) (? s) (& (? data)) (D (? ry)))
- (QUALIFIER (rl? d) (bwl? s))
- (WORD (4 #b1110)
- (3 data SHIFT-NUMBER)
- (1 (encode-rl d))
- (2 (encode-bwl s))
- (1 #b0)
- (2 ,bits)
- (3 ry)))
-
- (((? d) (? ea ea-m&a))
- (QUALIFIER (rl? d))
- (WORD (5 #b11100)
- (2 ,bits)
- (1 (encode-rl d))
- (2 #b11)
- (6 ea DESTINATION-EA)))))))
- (define-shift-instruction AS #b00)
- (define-shift-instruction LS #b01)
- (define-shift-instruction ROX #b10)
- (define-shift-instruction RO #b11))
-\f
-;;;; Bit Manipulation
-
-(let-syntax ((define-bit-manipulation
- (macro (keyword bits ea-register-target ea-immediate-target)
- `(define-instruction ,keyword
- (((D (? rx)) (? ea ,ea-register-target))
- (WORD (4 #b0000)
- (3 rx)
- (1 #b1)
- (2 ,bits)
- (6 ea DESTINATION-EA)))
-
- (((& (? bitnum)) (? ea ,ea-immediate-target))
- (WORD (8 #b00001000)
- (2 ,bits)
- (6 ea DESTINATION-EA))
- (immediate-byte bitnum))))))
- (define-bit-manipulation BTST #b00 ea-d ea-d&-&)
- (define-bit-manipulation BCHG #b01 ea-d&a ea-d&a)
- (define-bit-manipulation BCLR #b10 ea-d&a ea-d&a)
- (define-bit-manipulation BSET #b11 ea-d&a ea-d&a))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.9 1987/03/19 00:53:25 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; 68000 Instruction Set Description
-;;; Originally from GJS (who did the hard part).
-
-(declare (usual-integrations))
-\f
-;;;; Control Transfer
-
-(define-instruction B
- (((? c) S (@PCO (? o)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0110)
- (4 (encode-cc c))
- (8 o SIGNED)))
-
- (((? c) S (@PCR (? l)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0110)
- (4 (encode-cc c))
- (8 l SHORT-LABEL)))
-
- (((? c) L (@PCO (? o)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0110)
- (4 (encode-cc c))
- (8 #b00000000))
- (immediate-word o))
-
- (((? c) L (@PCR (? l)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0110)
- (4 (encode-cc c))
- (8 #b00000000))
- (relative-word l)))
-
-(define-instruction BRA
- ((S (@PCO (? o)))
- (WORD (8 #b01100000)
- (8 o SIGNED)))
-
- ((S (@PCR (? l)))
- (WORD (8 #b01100000)
- (8 l SHORT-LABEL)))
-
- ((L (@PCO (? o)))
- (WORD (16 #b0110000000000000))
- (immediate-word o))
-
- ((L (@PCR (? l)))
- (WORD (16 #b0110000000000000))
- (relative-word l)))
-
-(define-instruction BSR
- ((S (@PCO (? o)))
- (WORD (8 #b01100001)
- (8 o SIGNED)))
-
- ((S (@PCR (? o)))
- (WORD (8 #b01100001)
- (8 o SHORT-LABEL)))
-
- ((L (@PCO (? o)))
- (WORD (16 #b0110000100000000))
- (immediate-word o))
-
- ((L (@PCR (? l)))
- (WORD (16 #b0110000100000000))
- (relative-word l)))
-\f
-(define-instruction DB
- (((? c) (D (? rx)) (@PCO (? o)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0101)
- (4 (encode-cc c))
- (5 #b11001)
- (3 rx))
- (immediate-word o))
-
- (((? c) (D (? rx)) (@PCR (? l)))
- (QUALIFIER (cc? c))
- (WORD (4 #b0101)
- (4 (encode-cc c))
- (5 #b11001)
- (3 rx))
- (relative-word l)))
-
-(define-instruction JMP
- (((? ea ea-c))
- (WORD (10 #b0100111011)
- (6 ea DESTINATION-EA))))
-
-(define-instruction JSR
- (((? ea ea-c))
- (WORD (10 #b0100111010)
- (6 ea DESTINATION-EA))))
-
-(define-instruction RTE
- (()
- (WORD (16 #b0100111001110011))))
-
-(define-instruction RTR
- (()
- (WORD (16 #b0100111001110111))))
-
-(define-instruction RTS
- (()
- (WORD (16 #b0100111001110101))))
-
-(define-instruction TRAP
- (((& (? v)))
- (WORD (12 #b010011100100)
- (4 v))))
-
-(define-instruction TRAPV
- (()
- (WORD (16 #b0100111001110110))))
-\f
-;;;; Randomness
-
-(define-instruction CHK
- (((? ea ea-d) (D (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 #b110)
- (6 ea SOURCE-EA 'W))))
-
-(define-instruction LINK
- (((A (? rx)) (& (? d)))
- (WORD (13 #b0100111001010)
- (3 rx))
- (immediate-word d)))
-
-(define-instruction NOP
- (()
- (WORD (16 #b0100111001110001))))
-
-(define-instruction RESET
- (()
- (WORD (16 #b0100111001110000))))
-
-(define-instruction STOP
- (((& (? data)))
- (WORD (16 #b0100111001110010))
- (immediate-word data)))
-
-(define-instruction SWAP
- (((D (? rx)))
- (WORD (13 #b0100100001000)
- (3 rx))))
-
-(define-instruction UNLK
- (((A (? rx)))
- (WORD (13 #b0100111001011)
- (3 rx))))
-\f
-;;;; Data Transfer
-
-(define-instruction CLR
- (((? s) (? ea ea-d&a))
- (QUALIFIER (bwl? s))
- (WORD (8 #b01000010)
- (2 (encode-bwl s))
- (6 ea DESTINATION-EA))))
-
-(define-instruction EXG
- (((D (? rx)) (D (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b101000)
- (3 ry)))
-
- (((A (? rx)) (A (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b101001)
- (3 ry)))
-
- (((D (? rx)) (A (? ry)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b110001)
- (3 ry)))
-
- (((A (? ry)) (D (? rx)))
- (WORD (4 #b1100)
- (3 rx)
- (6 #b110001)
- (3 ry))))
-
-(define-instruction LEA
- (((? ea ea-c) (A (? rx)))
- (WORD (4 #b0100)
- (3 rx)
- (3 #b111)
- (6 ea DESTINATION-EA))))
-
-(define-instruction PEA
- (((? cea ea-c))
- (WORD (10 #b0100100001)
- (6 cea DESTINATION-EA))))
-
-(define-instruction S
- (((? c) (? dea ea-d&a))
- (QUALIFIER (cc? c))
- (WORD (4 #b0101)
- (4 (encode-cc c))
- (2 #b11)
- (6 dea DESTINATION-EA))))
-
-(define-instruction TAS
- (((? dea ea-d&a))
- (WORD (10 #b0100101011)
- (6 dea DESTINATION-EA))))
-\f
-(define-instruction MOVEQ
- (((& (? data)) (D (? rx)))
- (WORD (4 #b0111)
- (3 rx)
- (1 #b0)
- (8 data SIGNED))))
-
-(define-instruction MOVE
- (((? s) (? sea ea-all) (A (? rx))) ;MOVEA
- (QUALIFIER (wl? s))
- (WORD (3 #b001)
- (1 (encode-lw s))
- (3 rx)
- (3 #b001)
- (6 sea SOURCE-EA s)))
-
- (((? s) (? sea ea-all) (? dea ea-d&a))
- (QUALIFIER (bwl? s) (ea-b=>-A sea s))
- (WORD (2 #b00)
- (2 (encode-blw s))
- (6 dea DESTINATION-EA-REVERSED)
- (6 sea SOURCE-EA s)))
-
- ((W (? ea ea-d) (CCR)) ;MOVE to CCR
- (WORD (10 #b0100010011)
- (6 ea SOURCE-EA 'W)))
-
- ((W (? ea ea-d) (SR)) ;MOVE to SR
- (WORD (10 #b0100011011)
- (6 ea SOURCE-EA 'W)))
-
- ((W (SR) (? ea ea-d&a)) ;MOVE from SR
- (WORD (10 #b0100000011)
- (6 ea DESTINATION-EA)))
-
- ((L (USP) (A (? rx))) ;MOVE from USP
- (WORD (13 #b0100111001101)
- (3 rx)))
-
- ((L (A (? rx)) (USP)) ;MOVE to USP
- (WORD (13 #b0100111001100)
- (3 rx))))
-\f
-(define-instruction MOVEM
- (((? s) (? r) (? dea ea-c&a))
- (QUALIFIER (wl? s) (register-list? r))
- (WORD (9 #b010010001)
- (1 (encode-wl s))
- (6 dea DESTINATION-EA))
- (output-bit-string (encode-c@a+register-list r)))
-
- (((? s) (? r) (@-a (? rx)))
- (QUALIFIER (wl? s) (register-list? r))
- (WORD (9 #b010010001)
- (1 (encode-wl s))
- (3 #b100)
- (3 rx))
- (output-bit-string (encode-@-aregister-list r)))
-
- (((? s) (? sea ea-c) (? r))
- (QUALIFIER (wl? s) (register-list? r))
- (WORD (9 #b010011001)
- (1 (encode-wl s))
- (6 sea SOURCE-EA s))
- (output-bit-string (encode-c@a+register-list r)))
-
- (((? s) (@A+ (? rx)) (? r))
- (QUALIFIER (wl? s) (register-list? r))
- (WORD (9 #b010011001)
- (1 (encode-wl s))
- (3 #b011)
- (3 rx))
- (output-bit-string (encode-c@a+register-list r))))
-\f
-(define-instruction MOVEP
- (((? s) (D (? rx)) (@AO (? ry) (? o)))
- (QUALIFIER (wl? s))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b11)
- (1 (encode-wl s))
- (3 #b001)
- (3 ry))
- (offset-word o))
-
- (((? s) (D (? rx)) (@AR (? ry) (? l)))
- (QUALIFIER (wl? s))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b11)
- (1 (encode-wl s))
- (3 #b001)
- (3 ry))
- (relative-word l))
-
- (((? s) (@AO (? ry) (? o)) (D (? rx)))
- (QUALIFIER (wl? s))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b10)
- (1 (encode-wl s))
- (3 #b001)
- (3 ry))
- (offset-word o))
-
- (((? s) (@AR (? ry) (? l)) (D (? rx)))
- (QUALIFIER (wl? s))
- (WORD (4 #b0000)
- (3 rx)
- (2 #b10)
- (1 (encode-wl s))
- (3 #b001)
- (3 ry))
- (relative-word l)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.156 1987/04/12 00:24:56 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Rules for 68020
-
-(declare (usual-integrations))
-\f
-;;;; Basic machine instructions
-
-(define (register->register-transfer source target)
- `(,(machine->machine-register source target)))
-
-(define (home->register-transfer source target)
- `(,(pseudo->machine-register source target)))
-
-(define (register->home-transfer source target)
- `(,(machine->pseudo-register source target)))
-
-(define-integrable (pseudo->machine-register source target)
- (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
- (machine-register->memory source (pseudo-register-home target)))
-
-(define-integrable (pseudo-register-home register)
- (offset-reference regnum:regs-pointer
- (+ #x000A (register-renumber register))))
-
-(define-integrable (machine->machine-register source target)
- `(MOVE L ,(register-reference source) ,(register-reference target)))
-
-(define-integrable (machine-register->memory source target)
- `(MOVE L ,(register-reference source) ,target))
-
-(define-integrable (memory->machine-register source target)
- `(MOVE L ,source ,(register-reference target)))
-
-(define (offset-reference register offset)
- (if (zero? offset)
- (if (< register 8)
- `(@D ,register)
- `(@A ,(- register 8)))
- (if (< register 8)
- `(@DO ,register ,(* 4 offset))
- `(@AO ,(- register 8) ,(* 4 offset)))))
-
-(define (load-dnw n d)
- (cond ((zero? n) `(CLR W (D ,d)))
- ((<= -128 n 127) `(MOVEQ (& ,n) (D ,d)))
- (else `(MOVE W (& ,n) (D ,d)))))
-
-(define (test-dnw n d)
- (if (zero? n)
- `(TST W (D ,d))
- `(CMP W (& ,n) (D ,d))))
-\f
-(define (increment-anl an n)
- (case n
- ((0) '())
- ((1 2) `((ADDQ L (& ,(* 4 n)) (A ,an))))
- ((-1 -2) `((SUBQ L (& ,(* -4 n)) (A ,an))))
- (else `((LEA (@AO ,an ,(* 4 n)) (A ,an))))))
-
-(define (load-constant constant target)
- (if (non-pointer-object? constant)
- (load-non-pointer (primitive-type constant)
- (primitive-datum constant)
- target)
- `(MOVE L (@PCR ,(constant->label constant)) ,target)))
-
-(define (load-non-pointer type datum target)
- (cond ((not (zero? type))
- `(MOVE L (& ,(make-non-pointer-literal type datum)) ,target))
- ((and (zero? datum)
- (memq (car target) '(D @D @A @A+ @-A @AO @DO @AOX W L)))
- `(CLR L ,target))
- ((and (<= -128 datum 127) (eq? (car target) 'D))
- `(MOVEQ (& ,datum) ,target))
- (else
- `(MOVE L (& ,datum) ,target))))
-
-(define (test-byte n expression)
- (if (and (zero? n) (TSTable-expression? expression))
- `(TST B ,expression)
- `(CMP B (& ,n) ,expression)))
-
-(define (test-non-pointer type datum expression)
- (if (and (zero? type) (zero? datum) (TSTable-expression? expression))
- `(TST L ,expression)
- `(CMP L (& ,(make-non-pointer-literal type datum)) ,expression)))
-
-(define make-non-pointer-literal
- (let ((type-scale-factor (expt 2 24)))
- (lambda (type datum)
- (+ (* type type-scale-factor) datum))))
-
-(define (set-standard-branches! cc)
- (set-current-branches! (lambda (label)
- `((B ,cc L (@PCR ,label))))
- (lambda (label)
- `((B ,(invert-cc cc) L (@PCR ,label))))))
-\f
-(define (invert-cc cc)
- (cdr (or (assq cc
- '((T . F) (F . T)
- (HI . LS) (LS . HI)
- (HS . LO) (LO . HS)
- (CC . CS) (CS . CC)
- (NE . EQ) (EQ . NE)
- (VC . VS) (VS . VC)
- (PL . MI) (MI . PL)
- (GE . LT) (LT . GE)
- (GT . LE) (LE . GT)
- ))
- (error "INVERT-CC: Not a known CC" cc))))
-
-(define (expression->machine-register! expression register)
- (let ((target (register-reference register)))
- (let ((result
- (case (car expression)
- ((REGISTER) `((MOVE L ,(coerce->any (cadr expression)) ,target)))
- ((OFFSET)
- `((MOVE L ,(indirect-reference! (cadadr expression)
- (caddr expression))
- ,target)))
- ((CONSTANT) `(,(load-constant (cadr expression) target)))
- (else (error "Bad expression type" (car expression))))))
- (delete-machine-register! register)
- result)))
-
-(define-integrable (TSTable-expression? expression)
- (memq (car expression) '(D @D @A @A+ @-A @DO @AO @AOX W L)))
-
-(define-integrable (register-expression? expression)
- (memq (car expression) '(A D)))
-\f
-(define (indirect-reference! register offset)
- (offset-reference
- (if (machine-register? register)
- register
- (or (register-alias register false)
- ;; This means that someone has written an address out
- ;; to memory, something that should never happen.
- (error "Needed to load indirect register!" register)))
- offset))
-
-(define (coerce->any register)
- (if (machine-register? register)
- (register-reference register)
- (let ((alias (register-alias register false)))
- (if alias
- (register-reference alias)
- (pseudo-register-home register)))))
-
-(define (code-object-label-initialize code-object)
- false)
-
-(define (generate-n-times n limit instruction with-counter)
- (if (<= n limit)
- (let loop ((n n))
- (if (zero? n)
- '()
- `(,instruction
- ,@(loop (-1+ n)))))
- (let ((loop (generate-label 'LOOP)))
- (with-counter
- (lambda (counter)
- `(,(load-dnw (-1+ n) counter)
- (LABEL ,loop)
- ,instruction
- (DB F (D ,counter) (@PCR ,loop))))))))
-
-(define-integrable (data-register? register)
- (< register 8))
-
-(define (address-register? register)
- (and (< register 16)
- (>= register 8)))
-\f
-;;;; Registers/Entries
-
-(let-syntax ((define-entries
- (macro names
- (define (loop names index)
- (if (null? names)
- '()
- (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- '(@AO 6 ,index))
- (loop (cdr names) (+ index 6)))))
- `(BEGIN ,@(loop names #x00F0)))))
- (define-entries apply error wrong-number-of-arguments interrupt-procedure
- interrupt-continuation lookup-apply lookup access unassigned? unbound?
- set! define primitive-apply enclose setup-lexpr setup-ic-procedure))
-
-(define reg:temp '(@AO 6 #x0010))
-(define reg:enclose-result '(@AO 6 #x0014))
-(define reg:compiled-memtop '(@A 6))
-
-(define popper:apply-closure '(@AO 6 #x0168))
-(define popper:apply-stack '(@AO 6 #x01A8))
-(define popper:value '(@AO 6 #x01E8))
-\f
-;;;; Transfers to Registers
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. This is because
-;;; the register being assigned may be PSEUDO-REGISTER=? to one of the
-;;; dead registers, and thus would be flushed if the deletions
-;;; happened after the assignment.
-
-(define-rule statement
- (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n)))
- (increment-anl 7 n))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- `(,(load-constant source (coerce->any target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (QUALIFIER (pseudo-register? target))
- (move-to-alias-register! source 'DATA target)
- '())
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((target (move-to-alias-register! source 'DATA target)))
- `((AND L ,mask-reference ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((target (move-to-alias-register! source 'DATA target)))
- `((RO L L (& 8) ,target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (QUALIFIER (pseudo-register? target))
- (let ((source (indirect-reference! address offset)))
- (delete-dead-registers!)
- ;; The fact that the target register here is a data register is a
- ;; heuristic that works reasonably well since if the value is a
- ;; pointer, we will probably want to dereference it, which
- ;; requires that we first mask it.
- `((MOVE L ,source
- ,(register-reference (allocate-alias-register! target 'DATA))))))
-\f
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1))
- (let ((target* (coerce->any target)))
- (if (pseudo-register? target)
- (delete-dead-registers!))
- `((MOVE L (@A+ 7) ,target*))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (let ((target* (coerce->any target))
- (datum (coerce->any datum)))
- (if (pseudo-register? target)
- (delete-dead-registers!))
- (if (register-expression? target*)
- `((MOVE L ,datum ,reg:temp)
- (MOVE B (& ,type) ,reg:temp)
- (MOVE L ,reg:temp ,target*))
- `((MOVE L ,datum ,target*)
- (MOVE B (& ,type) ,target*)))))
-\f
-;;;; Transfers to Memory
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONSTANT (? object)))
- `(,(load-constant object (indirect-reference! a n))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (REGISTER (? r)))
- `((MOVE L ,(coerce->any r) ,(indirect-reference! a n))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (POST-INCREMENT (REGISTER 15) 1))
- `((MOVE L (@A+ 7) ,(indirect-reference! a n))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- (let ((target (indirect-reference! a n)))
- `((MOVE L ,(coerce->any r) ,target)
- (MOVE B (& ,type) ,target))))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
- (OFFSET (REGISTER (? a1)) (? n1)))
- (let ((source (indirect-reference! a1 n1)))
- `((MOVE L ,source ,(indirect-reference! a0 n0)))))
-\f
-;;;; Consing
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object)))
- `(,(load-constant object '(@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED))
- `(,(load-non-pointer type-code:unassigned 0 '(@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
- `((MOVE L ,(coerce->any r) (@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
- `((MOVE L ,(indirect-reference! r n) (@A+ 5))))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure)))
- (let ((temporary
- (register-reference (allocate-temporary-register! 'ADDRESS))))
- `((LEA (@PCR ,(procedure-external-label procedure)) ,temporary)
- (MOVE L ,temporary (@A+ 5))
- (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))
-\f
-;;;; Pushes
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object)))
- `(,(load-constant object '(@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED))
- `(,(load-non-pointer type-code:unassigned 0 '(@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
- `((MOVE L ,(coerce->any r) (@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- `((MOVE L ,(coerce->any r) (@-A 7))
- (MOVE B (& ,type) (@A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
- `((MOVE L ,(indirect-reference! r n) (@-A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (OFFSET-ADDRESS (REGISTER 15) (? n)))
- `((PEA ,(offset-reference a7 n))
- (MOVE B (& ,type-code:stack-environment) (@A 7))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
- (ENTRY:CONTINUATION (? continuation)))
- `((PEA (@PCR ,(continuation-label continuation)))
- (MOVE B (& ,type-code:return-address) (@A 7))))
-\f
-;;;; Predicates
-
-(define-rule predicate
- (TRUE-TEST (REGISTER (? register)))
- (set-standard-branches! 'NE)
- `(,(test-non-pointer (ucode-type false) 0 (coerce->any register))))
-
-(define-rule predicate
- (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
- (set-standard-branches! 'NE)
- `(,(test-non-pointer (ucode-type false) 0
- (indirect-reference! register offset))))
-
-(define-rule predicate
- (TYPE-TEST (REGISTER (? register)) (? type))
- (QUALIFIER (pseudo-register? register))
- (set-standard-branches! 'EQ)
- `(,(test-byte type
- (register-reference (load-alias-register! register 'DATA)))))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
- (QUALIFIER (pseudo-register? register))
- (set-standard-branches! 'EQ)
- (let ((reference (move-to-temporary-register! register 'DATA)))
- `((RO L L (& 8) ,reference)
- ,(test-byte type reference))))
-
-(define-rule predicate
- (UNASSIGNED-TEST (REGISTER (? register)))
- (set-standard-branches! 'EQ)
- `(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register))))
-
-(define-rule predicate
- (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
- (set-standard-branches! 'EQ)
- `(,(test-non-pointer (ucode-type unassigned) 0
- (indirect-reference! register offset))))
-\f
-;;;; Invocations
-
-(define-rule statement
- (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation))
- `(,@(generate-invocation-prefix prefix)
- ,(load-dnw number-pushed 0)
- (JMP ,entry:compiler-apply)))
-
-(define-rule statement
- (INVOCATION:JUMP (? n)
- (APPLY-CLOSURE (? frame-size) (? receiver-offset))
- (? continuation) (? procedure))
- `(,@(clear-map!)
- ,@(apply-closure-sequence frame-size receiver-offset
- (procedure-label procedure))))
-
-(define-rule statement
- (INVOCATION:JUMP (? n)
- (APPLY-STACK (? frame-size) (? receiver-offset)
- (? n-levels))
- (? continuation) (? procedure))
- `(,@(clear-map!)
- ,@(apply-stack-sequence frame-size receiver-offset n-levels
- (procedure-label procedure))))
-
-(define-rule statement
- (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure))
- (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK))))
- `(,@(generate-invocation-prefix prefix)
- (BRA L (@PCR ,(procedure-label procedure)))))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation)
- (? procedure))
- `(,@(generate-invocation-prefix prefix)
- ,(load-dnw number-pushed 0)
- (BRA L (@PCR ,(procedure-label procedure)))))
-\f
-(define-rule statement
- (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
- (? environment) (? name))
- (let ((set-environment (expression->machine-register! environment d4)))
- (delete-dead-registers!)
- `(,@set-environment
- ,@(generate-invocation-prefix prefix)
- ,(load-constant name '(D 5))
- (MOVE W (& ,(1+ number-pushed)) (D 0))
- (JMP ,entry:compiler-lookup-apply))))
-
-(define-rule statement
- (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation)
- (? primitive))
- `(,@(generate-invocation-prefix prefix)
- ,@(if (eq? primitive compiled-error-procedure)
- `(,(load-dnw (1+ number-pushed) 0)
- (JMP ,entry:compiler-error))
- `(,(load-dnw (primitive-datum primitive) 6)
- (JMP ,entry:compiler-primitive-apply)))))
-
-(define-rule statement
- (RETURN)
- `(,@(clear-map!)
- (CLR B (@A 7))
- (RTS)))
-\f
-(define (generate-invocation-prefix prefix)
- `(,@(clear-map!)
- ,@(case (car prefix)
- ((NULL) '())
- ((MOVE-FRAME-UP)
- (apply generate-invocation-prefix:move-frame-up (cdr prefix)))
- ((APPLY-CLOSURE)
- (apply generate-invocation-prefix:apply-closure (cdr prefix)))
- ((APPLY-STACK)
- (apply generate-invocation-prefix:apply-stack (cdr prefix)))
- (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix)))))
-
-(define (generate-invocation-prefix:move-frame-up frame-size how-far)
- (cond ((or (zero? frame-size) (zero? how-far)) '())
- ((= frame-size 1)
- `((MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))
- ,@(increment-anl 7 (-1+ how-far))))
- ((= frame-size 2)
- (if (= how-far 1)
- `((MOVE L (@AO 7 4) (@AO 7 8))
- (MOVE L (@A+ 7) (@A 7)))
- (let ((i `(MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))
- `(,i ,i ,@(increment-anl 7 (- how-far 2))))))
- (else
- (let ((temp-0 (allocate-temporary-register! 'ADDRESS))
- (temp-1 (allocate-temporary-register! 'ADDRESS)))
- `((LEA ,(offset-reference a7 frame-size)
- ,(register-reference temp-0))
- (LEA ,(offset-reference a7 (+ frame-size how-far))
- ,(register-reference temp-1))
- ,@(generate-n-times frame-size 5
- `(MOVE L
- (@-A ,(- temp-0 8))
- (@-A ,(- temp-1 8)))
- (lambda (generator)
- (generator (allocate-temporary-register! 'DATA))))
- (MOVE L ,(register-reference temp-1) (A 7)))))))
-
-(define (generate-invocation-prefix:apply-closure frame-size receiver-offset)
- (let ((label (generate-label)))
- `(,@(apply-closure-sequence frame-size receiver-offset label)
- (LABEL ,label))))
-
-(define (generate-invocation-prefix:apply-stack frame-size receiver-offset
- n-levels)
- (let ((label (generate-label)))
- `(,@(apply-stack-sequence frame-size receiver-offset n-levels label)
- (LABEL ,label))))
-\f
-;;;; Interpreter Calls
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? environment) (? name))
- (lookup-call entry:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? environment) (? name))
- (lookup-call entry:compiler-lookup environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
- (lookup-call entry:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
- (lookup-call entry:compiler-unbound? environment name))
-
-(define (lookup-call entry environment name)
- (let ((set-environment (expression->machine-register! environment a0)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@clear-map
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label))))))
-
-(define-rule statement
- (INTERPRETER-CALL:ENCLOSE (? number-pushed))
- `((MOVE L (A 5) ,reg:enclose-result)
- (MOVE B (& ,(ucode-type vector)) ,reg:enclose-result)
- ,(load-non-pointer (ucode-type manifest-vector) number-pushed
- '(@A+ 5))
- ,@(generate-n-times number-pushed 5 '(MOVE L (@A+ 7) (@A+ 5))
- (lambda (generator)
- `(,@(clear-registers! d0)
- ,@(generator 0)))))
-#| Alternate sequence which minimizes code size.
- `(,@(clear-registers! a0 a1 d0)
- (MOVE W (& ,number-pushed) (D 0))
- (JSR ,entry:compiler-enclose))|#
- )
-\f
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-set! environment name value))
-
-(define (assignment-call:default entry environment name value)
- (let ((set-environment (expression->machine-register! environment a0)))
- (let ((set-value (expression->machine-register! value a2)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@set-value
- ,@clear-map
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label)))))))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-define environment name type
- datum))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-set! environment name type
- datum))
-
-(define (assignment-call:cons-pointer entry environment name type datum)
- (let ((set-environment (expression->machine-register! environment a0)))
- (let ((datum (coerce->any datum)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- (MOVE L ,datum ,reg:temp)
- (MOVE B (& ,type) ,reg:temp)
- ,@clear-map
- (MOVE L ,reg:temp (A 2))
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label)))))))
-\f
-;;;; Procedure/Continuation Entries
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-
-;;; **** The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-
-(define-rule statement
- (PROCEDURE-HEAP-CHECK (? procedure))
- (let ((gc-label (generate-label)))
- `(,@(procedure-header procedure gc-label)
- (CMP L ,reg:compiled-memtop (A 5))
- (B GE S (@PCR ,gc-label)))))
-
-;;; Note: do not change the MOVE.W in the setup-lexpr call to a MOVEQ.
-;;; The setup-lexpr code assumes a fixed calling sequence to compute
-;;; the GC address if that is needed. This could be changed so that
-;;; the microcode determined how far to back up based on the argument,
-;;; or by examining the calling sequence.
-
-(define-rule statement
- (SETUP-LEXPR (? procedure))
- `(,@(procedure-header procedure false)
- (MOVE W
- (& ,(+ (length (procedure-required procedure))
- (length (procedure-optional procedure))
- (if (procedure/closure? procedure) 1 0)))
- (D 1))
- (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2))
- (JSR , entry:compiler-setup-lexpr)))
-
-(define-rule statement
- (CONTINUATION-HEAP-CHECK (? continuation))
- (let ((gc-label (generate-label))
- (internal-label (continuation-label continuation)))
- `((LABEL ,gc-label)
- (JSR ,entry:compiler-interrupt-continuation)
- ,@(make-external-label internal-label)
- (CMP L ,reg:compiled-memtop (A 5))
- (B GE S (@PCR ,gc-label)))))
-\f
-(define (procedure-header procedure gc-label)
- (let ((internal-label (procedure-label procedure)))
- (append! (if (procedure/closure? procedure)
- (let ((required (1+ (length (procedure-required procedure))))
- (optional (length (procedure-optional procedure)))
- (label (procedure-external-label procedure)))
- (if (and (procedure-rest procedure)
- (zero? required))
- (begin (set-procedure-external-label! procedure
- internal-label)
- `((ENTRY-POINT ,internal-label)))
- `((ENTRY-POINT ,label)
- ,@(make-external-label label)
- ,(test-dnw required 0)
- ,@(cond ((procedure-rest procedure)
- `((B GE S (@PCR ,internal-label))))
- ((zero? optional)
- `((B EQ S (@PCR ,internal-label))))
- (else
- (let ((wna-label (generate-label)))
- `((B LT S (@PCR ,wna-label))
- ,(test-dnw (+ required optional) 0)
- (B LE S (@PCR ,internal-label))
- (LABEL ,wna-label)))))
- (JMP ,entry:compiler-wrong-number-of-arguments))))
- '())
- (if gc-label
- `((LABEL ,gc-label)
- (JSR ,entry:compiler-interrupt-procedure))
- '())
- `(,@(make-external-label internal-label)))))
-
-(define (make-external-label label)
- `((DC W (- ,label ,*block-start-label*))
- (LABEL ,label)))
-\f
-;;;; Poppers
-
-(define-rule statement
- (MESSAGE-RECEIVER:CLOSURE (? frame-size))
- `((MOVE L (& ,(* frame-size 4)) (@-A 7))))
-
-(define-rule statement
- (MESSAGE-RECEIVER:STACK (? frame-size))
- `((MOVE L (& ,(+ #x00100000 (* frame-size 4))) (@-A 7))))
-
-(define-rule statement
- (MESSAGE-RECEIVER:SUBPROBLEM (? continuation))
- `((PEA (@PCR ,(continuation-label continuation)))
- (MOVE B (& ,type-code:return-address) (@A 7))
- (MOVE L (& #x00200000) (@-A 7))))
-
-(define (apply-closure-sequence frame-size receiver-offset label)
- `(,(load-dnw frame-size 1)
- (LEA (@AO 7 ,(* receiver-offset 4)) (A 0))
- (LEA (@PCR ,label) (A 1))
- (JMP ,popper:apply-closure)))
-
-(define (apply-stack-sequence frame-size receiver-offset n-levels label)
- `((MOVEQ (& ,n-levels) (D 0))
- ,(load-dnw frame-size 1)
- (LEA (@AO 7 ,(* receiver-offset 4)) (A 0))
- (LEA (@PCR ,label) (A 1))
- (JMP ,popper:apply-stack)))
-
-(define-rule statement
- (MESSAGE-SENDER:VALUE (? receiver-offset))
- `(,@(clear-map!)
- ,@(increment-anl 7 receiver-offset)
-(define popper:value '(@AO 6 #x01E8))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.44 1987/03/19 00:53:49 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Machine Model for 68020
-
-(declare (usual-integrations))
-\f(define (rtl:message-receiver-size:closure) 1)
-(define (rtl:message-receiver-size:stack) 1)
-(define (rtl:message-receiver-size:subproblem) 2)
-
-(define-integrable (stack->memory-offset offset)
- offset)
-
-(define (rtl:expression-cost expression)
- ;; Returns an estimate of the cost of evaluating the expression.
- ;; For simplicity, we try to estimate the actual number of cycles
- ;; that a typical code sequence would produce.
- (case (rtl:expression-type expression)
- ((CONSTANT)
- (let ((value (cadr expression)))
- (cond ((false? value) 4) ;clr.l reg
- ((or (eq? value true)
- (char? value)
- (and (integer? value)
- (<= -#x80000000 value #x7FFFFFFF)))
- 12) ;move.l #...,reg
- (else 16)))) ;move.l d(pc),reg
- ((CONS-POINTER)
- ;; Best case = 12 cycles, worst = 44
- ;; move.l reg,d(reg) = 16
- ;; move.b reg,d(reg) = 12
- ;; move.l d(reg),reg = 16
- (+ 30
- (rtl:expression-cost (rtl:cons-pointer-type expression))
- (rtl:expression-cost (rtl:cons-pointer-datum expression))))
- ((OBJECT->ADDRESS OBJECT->DATUM) 6) ;and.l d7,reg
- ;; move.l reg,d(reg) = 16
- ;; move.b d(reg),reg = 12
- ((OBJECT->TYPE) 28)
- ((OFFSET) 16) ;move.l d(reg),reg
- ((OFFSET-ADDRESS) 8) ;lea d(an),reg
- ((POST-INCREMENT) 12) ;move.l (reg)+,reg
- ((PRE-INCREMENT) 14) ;move.l -(reg),reg
- ((REGISTER) 4) ;move.l reg,reg
- ((UNASSIGNED) 12) ;move.l #data,reg
- ;; lea d(pc),reg = 8
- ;; move.l reg,d(reg) = 16
- ;; move.b #type,d(reg) = 16
- ;; move.l d(reg),reg = 16
- ((ENTRY:CONTINUATION ENTRY:PROCEDURE) 56)
- (else (error "Unknown expression type" expression))))
-\f
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER) (interpreter-stack-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY_TOP) 0)
- ((STACK_GUARD) 1)
- ((VALUE) 2)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- ((INTERPRETER-CALL-RESULT:ENCLOSE) 5)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-\f
-(define-integrable d0 0)
-(define-integrable d1 1)
-(define-integrable d2 2)
-(define-integrable d3 3)
-(define-integrable d4 4)
-(define-integrable d5 5)
-(define-integrable d6 6)
-(define-integrable d7 7)
-
-(define-integrable a0 8)
-(define-integrable a1 9)
-(define-integrable a2 10)
-(define-integrable a3 11)
-(define-integrable a4 12)
-(define-integrable a5 13)
-(define-integrable a6 14)
-(define-integrable a7 15)
-
-(define number-of-machine-registers 16)
-
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define (pseudo-register=? x y)
- (= (register-renumber x) (register-renumber y)))
-
-(define available-machine-registers
- (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3 a4))
-
-(define-integrable (register-contains-address? register)
- (memv register '(13 14 15)))
-
-(define register-type
- (let ((types (make-vector 16)))
- (let loop ((i 0) (j 8))
- (if (< i 8)
- (begin (vector-set! types i 'DATA)
- (vector-set! types j 'ADDRESS)
- (loop (1+ i) (1+ j)))))
- (lambda (register)
- (vector-ref types register))))
-
-(define register-reference
- (let ((references (make-vector 16)))
- (let loop ((i 0) (j 8))
- (if (< i 8)
- (begin (vector-set! references i `(D ,i))
- (vector-set! references j `(A ,i))
- (loop (1+ i) (1+ j))))) (lambda (register)
- (vector-ref references register))))
-
-(define mask-reference
- '(D 7))
-\f
-(define regnum:free-pointer a5)
-(define regnum:regs-pointer a6)
-(define regnum:stack-pointer a7)
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register d0))
-
-(define-integrable (interpreter-register:enclose)
- (rtl:make-offset (interpreter-regs-pointer) 5))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register d0))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register d0))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register d0))
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free-pointer))
-
-(define-integrable (interpreter-free-pointer? register)
- (= (rtl:register-number register) regnum:free-pointer))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define-integrable (interpreter-regs-pointer? register)
- (= (rtl:register-number register) regnum:regs-pointer))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define-integrable (interpreter-stack-pointer? register)
- (= (rtl:register-number register) regnum:stack-pointer))
-
-(define (lap:make-label-statement label)
- `(LABEL ,label))
-
-(define (lap:make-unconditional-branch label)
- `(BRA L (@PCR ,label)))
-
-(define (lap:make-entry-point label block-start-label)
- `((ENTRY-POINT ,label)
- (DC W (- ,label ,block-start-label))
- (LABEL ,label)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.12 1987/03/20 05:29:33 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler Make File for MC68020
-
-(declare (usual-integrations))
-\f
-(set-working-directory-pathname! "$zcomp")
-(load "base/rcs" system-global-environment)
-(load "base/load" system-global-environment)
-
-(load-system system-global-environment
- 'COMPILER-PACKAGE
- '(SYSTEM-GLOBAL-ENVIRONMENT)
- '(
- (SYSTEM-GLOBAL-ENVIRONMENT
- "base/pbs" ;bit-string read/write syntax
- )
-
- (COMPILER-PACKAGE
- "base/macros" ;compiler syntax
- "base/decls" ;declarations
-; "machines/bobcat/decls" ;more declarations
-
- "base/object" ;tagged object support
- "base/queue" ;queue abstraction
- "base/sets" ;set abstraction
- "source/mvalue" ;multiple-value support
-
- "machines/bobcat/machin" ;machine dependent stuff
- "base/toplev" ;top level
- "base/utils" ;odds and ends
- "base/cfg" ;control flow graph
- "base/ctypes" ;CFG datatypes
- "base/dtypes" ;DFG datatypes
- "base/bblock" ;Basic block datatype
- "base/dfg" ;data flow graph
- "base/rtltyp" ;RTL: type definitions
- "base/rtl" ;RTL: expression operations
- "base/rtlreg" ;RTL: registers
- "base/rtlcfg" ;RTL: CFG types
- "base/emodel" ;environment model
- "base/rtypes" ;RTL analyzer datatypes
- "base/nmatch" ;simple pattern matcher
- )
-
- (CONVERTER-PACKAGE
- "alpha/graphc" ;SCode->flow-graph converter
- )
-
- (DATAFLOW-PACKAGE
- "alpha/dflow" ;Dataflow analyzer
- )
-
- (RTL-GENERATOR-PACKAGE
- "front-end/rtlgen" ;RTL generator
- "front-end/rgcomb" ;RTL generator: combinations
- "base/linear" ;linearization
- )
-
- (RTL-CSE-PACKAGE
- "front-end/rcse" ;RTL common subexpression eliminator
- "front-end/rcseep" ;CSE expression predicates
- "front-end/rcsesr" ;CSE stack references
- "front-end/rcseht" ;CSE hash table
- "front-end/rcsesa" ;CSE state abstraction
- "front-end/rcserq" ;CSE register/quantity abstractions
- )
-
- (RTL-ANALYZER-PACKAGE
- "front-end/rlife" ;RTL register lifetime analyzer
- "front-end/ralloc" ;RTL register allocator
- )
-
- (LAP-GENERATOR-PACKAGE
- "back-end/lapgen" ;LAP generator.
- "back-end/regmap" ;Hardware register allocator.
- "machines/bobcat/lapgen" ;code generation rules.
- )
-
- (LAP-SYNTAXER-PACKAGE
- "back-end/syntax" ;Generic syntax phase
- "machines/bobcat/coerce" ;Coercions: integer -> bit string
- "back-end/asmmac" ;Macros for hairy syntax
- "machines/bobcat/insmac" ;Macros for hairy syntax
- "machines/bobcat/instr1" ;68000 Effective addressing
- "machines/bobcat/instr2" ;68000 Instructions
- "machines/bobcat/instr3" ; " "
- )
-
- (LAP-PACKAGE
- "machines/bobcat/assmd" ;Machine dependent
- "back-end/symtab" ;Symbol tables
- "back-end/block" ;Assembly blocks
- "back-end/laptop" ;Assembler top level
- )
-
- ))
-
-(in-package compiler-package
-
- (define compiler-system
- (make-environment
- (define :name "Liar (Bobcat 68020)")
- (define :version)
- (define :modification)
-
- (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.12 1987/03/20 05:29:33 cph Exp $"
- (lambda (filename version date time author state)
- (set! :version (car version))
- (set! :modification (cadr version))))))
-
- (add-system! compiler-system))
-
-(%ge compiler-package)
-(%gst (access compiler-syntax-table compiler-package))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/assmd.scm,v 1.29 1987/03/19 00:54:40 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Assembler Machine Dependencies
-
-(declare (usual-integrations))
-\f
-(define addressing-granularity 8)
-(define scheme-object-width 32)
-
-(define make-nmv-header)
-(let ()
-
-(set! make-nmv-header
-(named-lambda (make-nmv-header n)
- (bit-string-append (unsigned-integer->bit-string 24 n)
- nmv-type-string)))
-
-(define nmv-type-string
- (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))
-
-)
-
-(define (object->bit-string object)
- (bit-string-append
- (unsigned-integer->bit-string 24 (primitive-datum object))
- (unsigned-integer->bit-string 8 (primitive-type object))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/coerce.scm,v 1.4 1987/03/19 00:54:46 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Spectrum Specific Coercions
-
-(declare (usual-integrations))
-\f
-(define (parse-word expression tail)
- (expand-descriptors (cdr expression)
- (lambda (instruction size)
- (if (not (zero? (remainder size 32)))
- (error "PARSE-WORD: Instructions must be 32 bit multiples" size))
- (let ((instruction (apply optimize-group-syntax instruction)))
- (if (null? tail)
- `(CONS ,instruction '())
- `(CONS-SYNTAX ,instruction (CONS ,(car tail) '())))))))
-
-(define (expand-descriptors descriptors receiver)
- (if (null? descriptors)
- (receiver '() 0)
- (expand-descriptors (cdr descriptors)
- (lambda (instruction* size*)
- (expand-descriptor (car descriptors)
- (lambda (instruction size)
- (receiver (append! instruction instruction*)
- (+ size size*))))))))
-
-(define (expand-descriptor descriptor receiver)
- (let ((size (car descriptor)))
- (receiver `(,(integer-syntaxer (cadr descriptor)
- (if (null? (cddr descriptor))
- 'UNSIGNED
- (caddr descriptor))
- size))
- size)))
-\f
-(define (coerce-right-signed nbits)
- (let ((offset (1+ (expt 2 nbits))))
- (lambda (n)
- (unsigned-integer->bit-string nbits
- (if (negative? n)
- (+ (* n 2) offset)
- (* n 2))))))
-
-(define coerce-assemble3:x
- (standard-coercion
- (lambda (n)
- (+ (* (land n 3) 2) (quotient n 4)))))
-
-(define coerce-assemble12:X
- (standard-coercion
- (lambda (n)
- (let ((qr (integer-divide n 4)))
- (if (not (zero? (integer-divide-remainder qr)))
- (error "COERCE-ASSEMBLE12:X: offset not multiple of 4" n))
- (let ((n (integer-divide-quotient qr)))
- (+ (* (land n #x3FF) 2) (quotient (land n #x400) #x400)))))))
-
-(define coerce-assemble12:Y
- (standard-coercion
- (lambda (n)
- (quotient (land (quotient n 4) #x800) #x800))))
-
-(define coerce-assemble17:X
- (standard-coercion
- (lambda (n)
- (let ((qr (integer-divide n 4)))
- (if (not (zero? (integer-divide-remainder qr)))
- (error "COERCE-ASSEMBLE17:X: offset not multiple of 4" n))
- (quotient (land (integer-divide-quotient qr) #xF800) #x800)))))
-
-(define coerce-assemble17:Y
- (standard-coercion
- (lambda (n)
- (let ((n (quotient n 4)))
- (+ (quotient (land n #x400) #x400) (* (land n #x3FF) 2))))))
-
-(define coerce-assemble17:Z
- (standard-coercion
- (lambda (n)
- (+ (quotient (land (quotient n 4) #x10000) #x10000)))))
-
-(define coerce-assemble21:X
- (standard-coercion
- (lambda (n)
- (+ (* (land n #x7C) #x4000)
- (* (land n #x180) #x80)
- (* (land n #x3) #x1000)
- (quotient (land n #xFFE00) #x100)
- (quotient (land n #x100000) #x100000)))))
-\f
-(define make-coercion
- (coercion-maker
- `((ASSEMBLE3:X . ,coerce-assemble3:x)
- (ASSEMBLE12:X . ,coerce-assemble12:x)
- (ASSEMBLE12:Y . ,coerce-assemble12:y)
- (ASSEMBLE17:X . ,coerce-assemble17:x)
- (ASSEMBLE17:Y . ,coerce-assemble17:y)
- (ASSEMBLE17:Z . ,coerce-assemble17:z)
- (ASSEMBLE21:X . ,coerce-assemble21:x)
- (RIGHT-SIGNED . ,coerce-right-signed)
- (UNSIGNED . ,coerce-unsigned-integer)
- (SIGNED . ,coerce-signed-integer))))
-
-(define-coercion 'UNSIGNED 1)
-(define-coercion 'UNSIGNED 2)
-(define-coercion 'UNSIGNED 3)
-(define-coercion 'UNSIGNED 4)
-(define-coercion 'UNSIGNED 5)
-(define-coercion 'UNSIGNED 6)
-(define-coercion 'UNSIGNED 7)
-(define-coercion 'UNSIGNED 8)
-(define-coercion 'UNSIGNED 9)
-(define-coercion 'UNSIGNED 10)
-(define-coercion 'UNSIGNED 11)
-(define-coercion 'UNSIGNED 12)
-(define-coercion 'UNSIGNED 13)
-(define-coercion 'UNSIGNED 14)
-(define-coercion 'UNSIGNED 16)
-(define-coercion 'UNSIGNED 32)
-
-(define-coercion 'SIGNED 8)
-(define-coercion 'SIGNED 16)
-(define-coercion 'SIGNED 32)
-
-(define-coercion 'RIGHT-SIGNED 5)
-(define-coercion 'RIGHT-SIGNED 11)
-(define-coercion 'RIGHT-SIGNED 14)
-(define-coercion 'ASSEMBLE3:X 3)
-(define-coercion 'ASSEMBLE12:X 11)
-(define-coercion 'ASSEMBLE12:Y 1)
-(define-coercion 'ASSEMBLE17:X 5)
-(define-coercion 'ASSEMBLE17:Y 11)
-(define-coercion 'ASSEMBLE17:Z 1)
-(define-coercion 'ASSEMBLE21:X 21)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/lapgen.scm,v 1.137 1987/04/12 00:25:26 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Rules for Spectrum
-
-(declare (usual-integrations))
-\f
-;;;; Interface to Allocator
-
-(define (register->register-transfer source destination)
- `(,(machine->machine-register source destination)))
-
-(define (home->register-transfer source destination)
- `(,(pseudo->machine-register source destination)))
-
-(define (register->home-transfer source destination)
- `(,(machine->pseudo-register source destination)))
-
-(define-integrable (pseudo->machine-register source target)
- (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
- (machine-register->memory source (pseudo-register-home target)))
-
-(define-integrable (pseudo-register-home register)
- (index-reference regnum:regs-pointer
- (+ #x000A (register-renumber register))))
-\f
-;;;; Basic machine instructions
-
-(define-integrable (machine->machine-register source target)
- `(OR () ,source 0 ,target))
-
-(define-integrable (machine-register->memory source target)
- `(STW () ,source ,target))
-
-(define-integrable (machine-register->memory-post-increment source target)
- ;; Used for heap allocation
- `(STWM () ,source ,(index-reference target 1)))
-
-(define-integrable (machine-register->memory-pre-decrement source target)
- ;; Used for stack push
- `(STWM () ,source ,(index-reference target -1)))
-
-(define-integrable (memory->machine-register source target)
- `(LDW () ,source ,target))
-
-(define-integrable (memory-post-increment->machine-register source target)
- ;; Used for stack pop
- `(LDWM () ,(index-reference source 1) ,target))
-
-(define-integrable (invoke-entry entry)
- `(BE (N) ,entry))
-
-(define (assign&invoke-entry number target entry)
- (if (<= -8192 number 8191)
- `((BE () ,entry)
- (LDI () ,number ,target))
- `((LDIL () (LEFT ,number) ,target)
- (BE () ,entry)
- (LDO () (OFFSET (RIGHT ,number) ,target) ,target))))
-
-(define (branch->label label)
- `(BL (N) ,(label-relative-expression label) 0))
-
-(define-integrable (index-reference register offset)
- `(INDEX ,(* 4 offset) 0 ,(register-reference register)))
-
-(define-integrable (offset-reference register offset)
- `(OFFSET ,(* 4 offset) ,(register-reference register)))
-
-(define-integrable (short-offset? offset)
- (< offset 2048))
-
-(define (load-memory source offset target)
- `(LDW () ,(index-reference source offset) ,target))
-
-(define (store-memory source target offset)
- `(STW () ,source ,(index-reference target offset)))
-
-(define (load-memory-increment source offset target)
- `(LDWM () ,(index-reference source offset) ,target))
-
-(define (store-memory-increment source target offset)
- `(STWM () ,source ,(index-reference target offset)))
-\f
-;;;; Instruction Sequence Generators
-
-(define (indirect-reference! register offset)
- (index-reference
- (if (machine-register? register)
- register
- (or (register-alias register false)
- ;; This means that someone has written an address out
- ;; to memory, something that should never happen.
- (error "Needed to load indirect register!" register)))
- offset))
-
-(define (object->address source #!optional target)
- (if (unassigned? target) (set! target source))
- `((EXTRU () ,source 31 24 ,target)
- (OR () ,regnum:address-offset ,target ,target)))
-
-(define (register->machine-register register target)
- (if (machine-register? register)
- (machine->machine-register register target)
- (let ((alias (register-alias register false)))
- (if alias
- (machine->machine-register alias target)
- (pseudo->machine-register register target)))))
-
-(define (expression->machine-register! expression register)
- (let ((result
- (case (car expression)
- ((REGISTER)
- `(,(register->machine-register (cadr expression) register)))
- ((OFFSET)
- `(,(memory->machine-register
- (indirect-reference! (cadadr expression) (caddr expression))
- register)))
- ((CONSTANT)
- (scheme-constant->machine-register (cadr expression) register))
- (else (error "Bad expression type" (car expression))))))
- (delete-machine-register! register)
- result))
-
-(package (register->memory
- register->memory-post-increment
- register->memory-pre-decrement)
- (define ((->memory machine-register->memory) register target)
- `(,(machine-register->memory (guarantee-machine-register! register false)
- target)))
- (define-export register->memory
- (->memory machine-register->memory))
- (define-export register->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export register->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-\f
-(package (memory->memory
- memory->memory-post-increment
- memory->memory-pre-decrement)
- (define ((->memory machine-register->memory) source target)
- `(,(memory->machine-register source r1)
- ,(machine-register->memory r1 target)))
- (define-export memory->memory
- (->memory machine-register->memory))
- (define-export memory->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export memory->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-
-(package (memory-post-increment->memory
- memory-post-increment->memory-post-increment
- memory-post-increment->memory-pre-decrement)
- (define ((->memory machine-register->memory) source target)
- `(,(memory-post-increment->machine-register source r1)
- ,(machine-register->memory r1 target)))
- (define-export memory-post-increment->memory
- (->memory machine-register->memory))
- (define-export memory-post-increment->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export memory-post-increment->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-
-(package (scheme-constant->memory
- scheme-constant->memory-post-increment
- scheme-constant->memory-pre-decrement)
- (define ((->memory machine-register->memory) constant target)
- `(,@(scheme-constant->machine-register constant r1)
- ,(machine-register->memory r1 target)))
- (define-export scheme-constant->memory
- (->memory machine-register->memory))
- (define-export scheme-constant->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export scheme-constant->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-
-(define (scheme-constant->machine-register constant target)
- (if (non-pointer-object? constant)
- (non-pointer->machine-register (primitive-type constant)
- (primitive-datum constant)
- target)
- `(,(memory->machine-register (scheme-constant-reference constant)
- target))))
-
-(define-integrable (scheme-constant-reference constant)
- `(INDEX ,(label->machine-constant (constant->label constant))
- 0
- ,regnum:code-object-base))
-\f
-(define (non-pointer->machine-register type datum target)
- (if (and (zero? datum)
- (deposit-type-constant? type))
- (if (zero? type)
- `((OR () 0 0 ,target))
- (with-type-deposit-parameters type
- (lambda (const end)
- `((ZDEPI () ,const ,end 5 ,target)))))
- (let ((number (make-non-pointer type datum)))
- (if (<= -8192 number 8191)
- `((LDI () ,number ,target))
- `((LDIL () (LEFT ,number) ,target)
- (LDO () (OFFSET (RIGHT ,number) ,target) ,target))))))
-
-(package (non-pointer->memory
- non-pointer->memory-post-increment
- non-pointer->memory-pre-decrement)
- (define ((->memory machine-register->memory) constant target)
- `(,@(non-pointer->machine-register constant r1)
- ,(machine-register->memory r1 target)))
- (define-export non-pointer->memory
- (->memory machine-register->memory))
- (define-export non-pointer->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export non-pointer->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-
-(define (machine-constant->machine-register constant target)
- (non-pointer->machine-register (machine-constant->type constant)
- (machine-constant->datum constant)
- target))
-
-(package (machine-constant->memory
- machine-constant->memory-post-increment
- machine-constant->memory-pre-decrement)
- (define ((->memory machine-register->memory) constant target)
- `(,@(machine-constant->machine-register constant r1)
- ,(machine-register->memory r1 target)))
- (define-export machine-constant->memory
- (->memory machine-register->memory))
- (define-export machine-constant->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export machine-constant->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-\f
-(define (label->machine-register label target)
- (let ((constant (label->machine-constant label)))
- `((ADDIL () (LEFT ,constant) ,regnum:code-object-base)
- (LDO () (OFFSET (RIGHT ,constant) ,r1) ,target))))
-
-(define-integrable (label->machine-constant label)
- `(- ,label ,(code-object-base)))
-
-(package (label->memory
- label->memory-post-increment
- label->memory-pre-decrement)
- (define ((->memory machine-register->memory) type label target)
- (let ((temp (allocate-temporary-register! false)))
- `(,@(label->machine-register type label temp)
- ,(machine-register->memory temp target))))
- (define-export label->memory
- (->memory machine-register->memory))
- (define-export label->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export label->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-
-(define (typed-label->machine-register type label target)
- `(,@(label->machine-register label target)
- ,@(cons-pointer->machine-register type target target)))
-
-(package (typed-label->memory
- typed-label->memory-post-increment
- typed-label->memory-pre-decrement)
- (define ((->memory machine-register->memory) type label target)
- (let ((temp (allocate-temporary-register! false)))
- `(,@(typed-label->machine-register type label temp)
- ,(machine-register->memory temp target))))
- (define-export typed-label->memory
- (->memory machine-register->memory))
- (define-export typed-label->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define-export typed-label->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-\f
-(define (cons-pointer->machine-register type source target)
- (let ((source (guarantee-machine-register! source false)))
- (if (eqv? source target)
- (let ((temp (allocate-temporary-register! false)))
- `(,@(cons-pointer->machine-register type source temp)
- ,(machine->machine-register temp source)))
- `(,@(if (deposit-type-constant? type)
- (with-type-deposit-parameters type
- (lambda (type end)
- `((ZDEPI () ,type ,end 5 ,target))))
- `((LDI () ,type ,target)
- (ZDEP () ,target 7 8 ,target)))
- (DEP () ,source 31 24 ,target)))))
-
-(package (cons-pointer->memory
- cons-pointer->memory-post-increment
- cons-pointer->memory-pre-decrement)
- (define ((->memory machine-register->memory) type source target)
- (let ((temp (allocate-temporary-register! false)))
- `(,@(cons-pointer->machine-register type source temp)
- ,(machine-register->memory temp target))))
- (define cons-pointer->memory
- (->memory machine-register->memory))
- (define cons-pointer->memory-post-increment
- (->memory machine-register->memory-post-increment))
- (define cons-pointer->memory-pre-decrement
- (->memory machine-register->memory-pre-decrement)))
-\f
-(define (test:machine/machine-register condition source0 source1 receiver)
- (let ((make-branch
- (lambda (completer)
- (lambda (label)
- `((COMB (,completer N) ,source0 ,source1
- ,(label-relative-expression label)))))))
- (receiver '()
- (make-branch condition)
- (make-branch (invert-test-completer condition)))))
-
-(define (test:short-machine-constant/machine-register condition constant source
- receiver)
- (let ((make-branch
- (lambda (completer)
- (lambda (label)
- `((COMIB (,completer N) ,constant ,source
- ,(label-relative-expression label)))))))
- (receiver '()
- (make-branch condition)
- (make-branch (invert-test-completer condition)))))
-
-(define (invert-test-completer completer)
- (cdr (or (assq completer
- '((EQ . LTGT) (LTGT . EQ)
- (LT . GTEQ) (GTEQ . LT)
- (GT . LTEQ) (GT . LTEQ)
- (LTLT . GTGTEQ) (GTGTEQ . LTLT)
- (GTGT . LTLTEQ) (GTGT . LTLTEQ)
- ))
- (error "Unknown test completer" completer))))
-
-(define (test:machine-constant/machine-register condition constant source
- receiver)
- (cond ((zero? constant)
- (test:machine/machine-register condition 0 source receiver))
- ((test-short-constant? constant)
- (test:short-machine-constant/machine-register condition constant
- source receiver))
- (else
- `(,@(non-pointer->machine-register 0 constant r1)
- ,@(test:machine/machine-register condition r1 source receiver)))))
-
-(define (test:machine-constant/register condition constant source receiver)
- (test:machine-constant/machine-register
- condition constant (guarantee-machine-register! source false) receiver))
-
-(define (test:machine-constant/memory condition constant source receiver)
- (let ((temp (allocate-temporary-register! false)))
- `(,(memory->machine-register source temp)
- ,@(test:machine-constant/machine-register condition constant temp
- receiver))))
-\f
-(define (test:type/machine-register condition type source receiver)
- (let ((temp (allocate-temporary-register! false)))
- `(,(extract-type-machine->machine-register source temp)
- ,@(test:machine-constant/machine-register condition type temp
- receiver))))
-
-(define (test:type/register condition type source receiver)
- (test:type/machine-register condition type
- (guarantee-machine-register! source false)
- receiver))
-
-(define (test:type/memory condition type source receiver)
- (let ((temp (allocate-temporary-register! false)))
- `(,(memory->machine-register source temp)
- ,@(cond ((zero? type)
- (test:machine/machine-register condition 0 temp receiver))
- ((test-short-constant? type)
- `(,(extract-type-machine->machine-register temp temp)
- ,@(test:short-machine-constant/machine-register condition
- type
- temp
- receiver)))
- (else
- `(,@(non-pointer->machine-register 0 type r1)
- ,(extract-type-machine->machine-register temp temp)
- ,@(test:machine/machine-register condition r1 temp
- receiver)))))))
-
-(define (standard-predicate-receiver prefix consequent alternative)
- (set-current-branches! consequent alternative)
- prefix)
-
-(define ((inline-predicate-receiver label) prefix consequent alternative)
- `(,@prefix ,@(consequent label)))
-
-(define-integrable (extract-type-machine->machine-register source target)
- `(EXTRU () ,source 7 8 ,target))
-
-(define-integrable (test-short-constant? constant)
- (<= -16 constant 15))
-\f
-(define (deposit-type-constant? n)
- ;; Assume that (<= 0 n 127).
- (or (< n 16)
- (zero? (remainder n
- (cond ((< n 32) 2)
- ((< n 64) 4)
- (else 8))))))
-
-(define (with-type-deposit-parameters type receiver)
- ;; This one is for type codes, assume that (<= 0 n 127).
- ;; Also assume that `(deposit-type-constant? type)' is true.
- (cond ((< type 16) (receiver type 7))
- ((< type 32) (receiver (quotient type 2) 6))
- ((< type 64) (receiver (quotient type 4) 5))
- (else (receiver (quotient type 8) 4))))
-
-(define (code-object-label-initialize code-object)
- (cond ((procedure? code-object) false)
- ((continuation? code-object) (continuation-label code-object))
- ((quotation? code-object) (quotation-label code-object))
- (else
- (error "CODE-OBJECT-LABEL-INITIALIZE: Unknown code object type"
- code-object))))
-
-(define (code-object-base)
- ;; This will fail if the difference between the beginning of the
- ;; code-object and LABEL is greater than 11 bits (signed).
- (or *code-object-label*
- (let ((label (generate-label)))
- (prefix-instructions!
- `((BL () 0 ,regnum:code-object-base)
- (LABEL ,label)))
- (let ((label `(+ ,label 4)))
- (set! *code-object-label* label)
- label))))
-
-(define (generate-n-times n limit prefix suffix with-counter)
- (if (<= n limit)
- (let loop ((n n))
- (if (zero? n)
- '()
- `(,@prefix
- ,suffix
- ,@(loop (-1+ n)))))
- (let ((loop (generate-label 'LOOP)))
- (with-counter
- (lambda (counter)
- `(,@(machine-constant->machine-register (-1+ n) counter)
- (LABEL ,loop)
- ,@prefix
- (ADDIBF (EQ) -1 ,counter ,(label-relative-expression loop))
- ,suffix))))))
-
-(define-integrable (label-relative-expression label)
- `(- (- ,label *PC*) 8))
-\f
-;;;; Registers/Entries
-
-(let-syntax ((define-entries
- (macro names
- (define (loop names index)
- (if (null? names)
- '()
- (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- `(INDEX ,,index 5 ,regnum:regs-pointer))
- (loop (cdr names) (+ index 8)))))
- `(BEGIN ,@(loop names #x00F0)))))
- (define-entries apply error wrong-number-of-arguments interrupt-procedure
- interrupt-continuation lookup-apply lookup access unassigned? unbound?
- set! define primitive-apply enclose setup-lexpr setup-ic-procedure))
-
-(define reg:temp `(INDEX #x0010 0 ,regnum:regs-pointer))
-(define reg:compiled-memtop `(INDEX 0 0 ,regnum:regs-pointer))
-
-(define popper:apply-closure `(INDEX 400 5 ,regnum:regs-pointer))
-(define popper:apply-stack `(INDEX 528 5 ,regnum:regs-pointer))
-(define popper:value `(INDEX 656 5 ,regnum:regs-pointer))
-
-(package (type->machine-constant
- make-non-pointer
- machine-constant->type
- machine-constant->datum)
- (define type-scale-factor
- (expt 2 24))
- (define-export (type->machine-constant type)
- (* type type-scale-factor))
- (define-export (make-non-pointer type datum)
- (+ (* type type-scale-factor) datum))
- (define-export (machine-constant->type constant)
- (quotient constant type-scale-factor))
- (define-export (machine-constant->datum constant)
- (remainder constant type-scale-factor)))
-
-(define constant:compiled-expression
- (type->machine-constant (ucode-type compiled-expression)))
-
-(define constant:return-address
- (type->machine-constant (ucode-type return-address)))
-
-(define constant:unassigned
- (make-non-pointer (ucode-type unassigned) 0))
-
-(define constant:false
- (make-non-pointer (ucode-type false) 0))
-\f
-;;;; Transfers to Registers
-
-;;; All assignments to pseudo registers are required to delete the
-;;; dead registers BEFORE performing the assignment. This is because
-;;; the register being assigned may be PSEUDO-REGISTER=? to one of the
-;;; dead registers, and thus would be flushed if the deletions
-;;; happened after the assignment.
-
-(define-rule statement
- (ASSIGN (REGISTER 30) (OFFSET-ADDRESS (REGISTER 30) (? n)))
- `((LDO () ,(offset-reference regnum:stack-pointer n) ,r30)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
- (QUALIFIER (pseudo-register? target))
- (scheme-constant->machine-register source
- (allocate-assignment-alias! target
- false)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
- (QUALIFIER (pseudo-register? target))
- (move-to-alias-register! source false target)
- '())
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (object->address (move-to-alias-register! source false target)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (let ((target (move-to-alias-register! source false target)))
- `(,(extract-type-machine->machine-register target target))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
- (QUALIFIER (and (pseudo-register? target) (short-offset? offset)))
- (let ((source (indirect-reference! address offset))) ;force eval order.
- `(,(memory->machine-register source
- (allocate-assignment-alias! target false)))))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? source)) 1))
- (QUALIFIER (pseudo-register? target))
- (memory-post-increment->machine-register
- source
- (allocate-assignment-alias! target false)))
-
-(define-rule statement
- (ASSIGN (REGISTER (? target))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
- (QUALIFIER (pseudo-register? target))
- (cons-pointer->machine-register type datum
- (allocate-assignment-alias! target false)))
-\f
-;;;; Transfers to Memory
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONSTANT (? object)))
- (QUALIFIER (short-offset? n))
- (scheme-constant->memory object (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (REGISTER (? r)))
- (QUALIFIER (short-offset? n))
- (register->memory r (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (POINTER-INCREMENT (REGISTER (? source)) 1))
- (QUALIFIER (short-offset? n))
- (memory-post-increment->memory source (indirect-reference! a n)))
-
-(define-rule statement
- ;; The code assumes r cannot be trashed
- (ASSIGN (OFFSET (REGISTER (? a)) (? n))
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- (QUALIFIER (short-offset? n))
- (cons-pointer->memory type r (indirect-reference! a n)))
-
-(define-rule statement
- (ASSIGN (OFFSET (REGISTER (? r-target)) (? n-target))
- (OFFSET (REGISTER (? r-source)) (? n-source)))
- (QUALIFIER (and (short-offset? n-target) (short-offset? n-source)))
- (memory->memory (indirect-reference! r-source n-source)
- (indirect-reference! r-target n-target)))
-\f
-;;;; Consing
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (CONSTANT (? object)))
- (scheme-constant->memory-post-increment object r25))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (REGISTER (? r)))
- (register->memory-post-increment r r25))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (OFFSET (REGISTER (? r)) (? n)))
- (memory->memory-post-increment (indirect-reference! r n) r25))
-
-(define-rule statement
- (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (ENTRY:PROCEDURE (? procedure)))
- (typed-label->memory-post-increment (ucode-type compiled-expression)
- (procedure-external-label procedure)
- r25))
-\f
-;;;; Pushes
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (CONSTANT (? object)))
- (scheme-constant->memory-pre-decrement object r30))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (UNASSIGNED))
- (scheme-constant->memory-pre-decrement constant:unassigned r30))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (REGISTER (? r)))
- (register->memory-pre-decrement r r30))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
- (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
- (cons-pointer->memory-pre-decrement type r r30))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (OFFSET (REGISTER (? r)) (? n)))
- (QUALIFIER (short-offset? n))
- (memory->memory-pre-decrement (indirect-reference! r n) r30))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
- (OFFSET-ADDRESS (REGISTER 30) (? n)))
- (QUALIFIER (short-offset? n))
- (let ((temp (allocate-temporary-register! false)))
- `((LDI () ,(ucode-type stack-environment) ,temp)
- (LDO () ,(offset-reference r30 n) ,r1)
- (DEP () ,temp 7 8 ,r1)
- ,@(register->memory-pre-decrement r1 r30))))
-
-(define-rule statement
- (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
- (ENTRY:CONTINUATION (? continuation)))
- (typed-label->memory-pre-decrement (ucode-type return-address)
- (continuation-label continuation)
- r30))
-\f
-;;;; Predicates
-
-(define-rule predicate
- (TRUE-TEST (REGISTER (? register)))
- (test:machine-constant/register 'LTGT constant:false register
- standard-predicate-receiver))
-
-(define-rule predicate
- (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
- (test:machine-constant/memory 'LTGT constant:false
- (indirect-reference! register offset)
- standard-predicate-receiver))
-
-(define-rule predicate
- (TYPE-TEST (REGISTER (? register)) (? type))
- (test:machine-constant/machine-register 'LTGT type register
- standard-predicate-receiver))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
- (test:type/register 'LTGT type register standard-predicate-receiver))
-
-(define-rule predicate
- (UNASSIGNED-TEST (REGISTER (? register)))
- (test:machine-constant/register 'LTGT constant:unassigned register
- standard-predicate-receiver))
-
-(define-rule predicate
- (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
- (test:machine-constant/memory 'LTGT constant:unassigned
- (indirect-reference! register offset)
- standard-predicate-receiver))
-\f
-;;;; Invocations
-
-(define-rule statement
- (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation))
- `(,@(generate-invocation-prefix prefix)
- ,@(assign&invoke-entry number-pushed regnum:frame-size
- entry:compiler-apply)))
-
-(define-rule statement
- (INVOCATION:JUMP (? n)
- (APPLY-CLOSURE (? frame-size) (? receiver-offset))
- (? continuation) (? procedure))
- `(,@(clear-map!)
- ,@(apply-closure-sequence frame-size receiver-offset
- (procedure-label procedure))))
-
-(define-rule statement
- (INVOCATION:JUMP (? n)
- (APPLY-STACK (? frame-size) (? receiver-offset)
- (? n-levels))
- (? continuation) (? procedure))
- `(,@(clear-map!)
- ,@(apply-stack-sequence frame-size receiver-offset n-levels
- (procedure-label procedure))))
-
-(define-rule statement
- (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure))
- (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK))))
- `(,@(generate-invocation-prefix prefix)
- ,(branch->label (procedure-label procedure))))
-
-(define-rule statement
- (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation)
- (? procedure))
- `(,@(generate-invocation-prefix prefix)
- ,@(machine-constant->machine-register number-pushed regnum:frame-size)
- ,(branch->label (procedure-label procedure))))
-\f
-(define-rule statement
- (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
- (? environment) (? name))
- (let ((set-environment
- (expression->machine-register! environment regnum:call-argument-0)))
- (delete-dead-registers!)
- `(,@set-environment
- ,@(generate-invocation-prefix prefix)
- ,@(scheme-constant->machine-register name regnum:call-argument-1)
- ,@(assign&invoke-entry (1+ number-pushed) regnum:frame-size
- entry:compiler-lookup-apply))))
-
-(define-rule statement
- (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation)
- (? primitive))
- `(,@(generate-invocation-prefix prefix)
- ,@(if (eq? primitive compiled-error-procedure)
- (assign&invoke-entry number-pushed regnum:frame-size
- entry:compiler-error)
- ;; Simple thing for now.
- (assign&invoke-entry (primitive-datum primitive)
- regnum:call-argument-0
- entry:compiler-primitive-apply))))
-
-(define-rule statement
- (RETURN)
- `(,@(clear-map!)
- ,(memory-post-increment->machine-register regnum:stack-pointer
- regnum:code-object-base)
- ,@(object->address regnum:code-object-base)
- (BE (N) (INDEX 0 1 ,regnum:code-object-base))))
-\f
-(define (generate-invocation-prefix prefix)
- `(,@(clear-map!)
- ,@(case (car prefix)
- ((NULL) '())
- ((MOVE-FRAME-UP)
- (apply generate-invocation-prefix:move-frame-up (cdr prefix)))
- ((APPLY-CLOSURE)
- (apply generate-invocation-prefix:apply-closure (cdr prefix)))
- ((APPLY-STACK)
- (apply generate-invocation-prefix:apply-stack (cdr prefix)))
- (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix)))))
-
-(define (generate-invocation-prefix:move-frame-up frame-size how-far)
- (cond ((or (zero? frame-size) (zero? how-far)) '())
- ((= frame-size 1)
- `(,(load-memory-increment regnum:stack-pointer (+ frame-size how-far)
- r1)
- ,(store-memory r1 regnum:stack-pointer 0)))
- ((= frame-size 2)
- (let ((temp (allocate-temporary-register! false)))
- `(,(load-memory-increment regnum:stack-pointer 1 r1)
- ,(load-memory-increment regnum:stack-pointer (-1+ how-far) temp)
- ,(store-memory r1 regnum:stack-pointer 0)
- ,(store-memory temp regnum:stack-pointer 1))))
- (else
- (let ((temp0 (allocate-temporary-register! false))
- (temp1 (allocate-temporary-register! false)))
- `((LDO ()
- ,(offset-reference regnum:stack-pointer frame-size)
- ,temp0)
- (LDO ()
- ,(offset-reference regnum:stack-pointer
- (+ frame-size how-far))
- ,temp1)
- ,@(generate-n-times
- frame-size 5
- `(,(load-memory-increment temp0 -1 r1))
- (store-memory-increment r1 temp1 -1)
- (lambda (generator)
- (generator (allocate-temporary-register! false))))
- ,(machine->machine-register temp1 regnum:stack-pointer))))))
-
-(define (generate-invocation-prefix:apply-closure frame-size receiver-offset)
- (let ((label (generate-label)))
- `(,@(apply-closure-sequence frame-size receiver-offset label)
- (LABEL ,label))))
-
-(define (generate-invocation-prefix:apply-stack frame-size receiver-offset
- n-levels)
- (let ((label (generate-label)))
- `(,@(apply-stack-sequence frame-size receiver-offset n-levels label)
- (LABEL ,label))))
-\f
-;;;; Environment Calls
-
-(define-rule statement
- (INTERPRETER-CALL:ACCESS (? environment) (? name))
- (lookup-call entry:compiler-access environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:LOOKUP (? environment) (? name))
- (lookup-call entry:compiler-lookup environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
- (lookup-call entry:compiler-unassigned? environment name))
-
-(define-rule statement
- (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
- (lookup-call entry:compiler-unbound? environment name))
-
-(define (lookup-call entry environment name)
- (let ((set-environment
- (expression->machine-register! environment regnum:call-argument-0)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@clear-map
- ,(scheme-constant->machine-register name regnum:argument-1)
- (BLE (N) ,entry)
- ,@(make-external-label (generate-label))))))
-
-(define-rule statement
- (INTERPRETER-CALL:ENCLOSE (? number-pushed))
- `(,@(cons-pointer->machine-register (ucode-type vector) regnum:free-pointer
- regnum:call-value)
- ,@(non-pointer->memory-post-increment (ucode-type manifest-vector)
- number-pushed
- regnum:free-pointer)
- ,@(generate-n-times number-pushed 5
- `(,(load-memory-increment regnum:stack-pointer 1 r1))
- (store-memory-increment r1 regnum:free-pointer 1)
- (lambda (generator)
- (generator (allocate-temporary-register! false))))))
-\f
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-define environment name value))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
- (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
- (assignment-call:default entry:compiler-set! environment name value))
-
-(define (assignment-call:default entry environment name value)
- (let ((set-environment
- (expression->machine-register! environment regnum:call-argument-0)))
- (let ((set-value
- (expression->machine-register! value regnum:call-argument-2)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@set-value
- ,@clear-map
- ,@(scheme-constant->machine-register name regnum:call-argument-1)
- (BLE (N) ,entry)
- ,@(make-external-label (generate-label)))))))
-
-(define-rule statement
- (INTERPRETER-CALL:DEFINE (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-define environment name type
- datum))
-
-(define-rule statement
- (INTERPRETER-CALL:SET! (? environment) (? name)
- (CONS-POINTER (CONSTANT (? type))
- (REGISTER (? datum))))
- (assignment-call:cons-pointer entry:compiler-set! environment name type
- datum))
-
-(define (assignment-call:cons-pointer entry environment name type datum)
- (let ((set-environment
- (expression->machine-register! environment regnum:call-argument-0)))
- (let ((set-value
- (cons-pointer->machine-register type datum regnum:call-argument-2)))
- (let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@set-value
- ,@clear-map
- ,@(scheme-constant->machine-register name regnum:call-argument-1)
- (BLE (N) ,entry)
- ,@(make-external-label (generate-label)))))))
-\f
-;;;; Procedure/Continuation Entries
-
-;;; The following calls MUST appear as the first thing at the entry
-;;; point of a procedure. They assume that the register map is clear
-;;; and that no register contains anything of value.
-
-;;; **** The only reason that this is true is that no register is live
-;;; across calls. If that were not true, then we would have to save
-;;; any such registers on the stack so that they would be GC'ed
-;;; appropriately.
-
-(define-rule statement
- (PROCEDURE-HEAP-CHECK (? procedure))
- (let ((label (generate-label)))
- `(,@(procedure-header procedure)
- (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer
- ,(label-relative-expression label))
- (BLE (N) ,entry:compiler-interrupt-procedure)
- (LABEL ,label))))
-
-(define-rule statement
- (CONTINUATION-HEAP-CHECK (? continuation))
- (let ((label (generate-label)))
- `(,@(make-external-label (continuation-label continuation))
- (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer
- ,(label-relative-expression label))
- (BLE (N) ,entry:compiler-interrupt-procedure)
- (LABEL ,label))))
-\f
-(define (procedure-header procedure)
- (let ((internal-label (procedure-label procedure)))
- (append! (if (procedure/closure? procedure)
- (let ((required (1+ (length (procedure-required procedure))))
- (optional (length (procedure-optional procedure)))
- (label (procedure-external-label procedure)))
- (if (and (procedure-rest procedure)
- (zero? required))
- (begin (set-procedure-external-label! procedure
- internal-label)
- `((ENTRY-POINT ,internal-label)))
- `((ENTRY-POINT ,label)
- ,@(make-external-label label)
- ,@(cond ((procedure-rest procedure)
- (test:machine-constant/machine-register
- 'GTEQ required regnum:frame-size
- (inline-predicate-receiver internal-label)))
- ((zero? optional)
- (test:machine-constant/machine-register
- 'EQ required regnum:frame-size
- (inline-predicate-receiver internal-label)))
- (else
- (let ((wna-label (generate-label)))
- `(,@(test:machine-constant/machine-register
- 'LT required regnum:frame-size
- (inline-predicate-receiver wna-label))
- ,@(test:machine-constant/machine-register
- 'LTEQ (+ required optional)
- regnum:frame-size
- (inline-predicate-receiver
- internal-label))
- (LABEL ,wna-label)))))
- ,(invoke-entry
- entry:compiler-wrong-number-of-arguments))))
- '())
- `(,@(make-external-label internal-label)))))
-
-(define *block-start-label*)
-
-(define (make-external-label label)
- `((WORD (- ,label ,*block-start-label*))
- (LABEL ,label)))
-\f
-;;;; Poppers
-
-(define-rule statement
- (MESSAGE-RECEIVER:CLOSURE (? frame-size))
- (machine-constant->memory-pre-decrement (* frame-size 4) r30))
-
-(define-rule statement
- (MESSAGE-RECEIVER:STACK (? frame-size))
- (machine-constant->memory-pre-decrement (+ #x00200000 (* frame-size 4))
- r30))
-
-(define-rule statement
- (MESSAGE-RECEIVER:SUBPROBLEM (? continuation))
- `(,@(typed-label->memory-pre-decrement (ucode-type return-address)
- (continuation-label continuation)
- r30)
- ,@(machine-constant->memory-pre-decrement #x00400000 r30)))
-
-(define (apply-closure-sequence frame-size receiver-offset label)
- `(,@(machine-constant->machine-register (* frame-size 4) r19)
- (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20)
- ,@(label->machine-register label r21)
- (BLE (N) ,popper:apply-closure)))
-
-(define (apply-stack-sequence frame-size receiver-offset n-levels label)
- `(,@(machine-constant->machine-register (* frame-size 4) r19)
- (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r20)
- ,@(label->machine-register label r21)
- ,@(machine-constant->machine-register n-levels r22)
- (BLE (N) ,popper:apply-stack)))
-
-(define-rule statement
- (MESSAGE-SENDER:VALUE (? receiver-offset))
- `(,@(clear-map!)
- (LDO () ,(offset-reference r30 (* receiver-offset 4)) ,r30)
- (BLE (N) ,popper:value)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/machin.scm,v 1.41 1987/03/19 00:55:54 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Machine Model for Spectrum
-
-(declare (usual-integrations))
-\f
-(define (rtl:message-receiver-size:closure) 1)
-(define (rtl:message-receiver-size:stack) 1)
-(define (rtl:message-receiver-size:subproblem) 1)
-
-(define-integrable (stack->memory-offset offset)
- offset)
-
-(define (rtl:expression-cost expression)
- ;; Returns an estimate of the cost of evaluating the expression.
- ;; For time being, disable this feature.
- 1)
-
-(define (rtl:machine-register? rtl-register)
- (case rtl-register
- ((STACK-POINTER) (interpreter-stack-pointer))
- ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
- ((INTERPRETER-CALL-RESULT:ENCLOSE) (interpreter-register:enclose))
- ((INTERPRETER-CALL-RESULT:LOOKUP) (interpreter-register:lookup))
- ((INTERPRETER-CALL-RESULT:UNASSIGNED?) (interpreter-register:unassigned?))
- ((INTERPRETER-CALL-RESULT:UNBOUND?) (interpreter-register:unbound?))
- (else false)))
-
-(define (rtl:interpreter-register? rtl-register)
- (case rtl-register
- ((MEMORY_TOP) 0)
- ((STACK_GUARD) 1)
- ((VALUE) 2)
- ((ENVIRONMENT) 3)
- ((TEMPORARY) 4)
- (else false)))
-
-(define (rtl:interpreter-register->offset locative)
- (or (rtl:interpreter-register? locative)
- (error "Unknown register type" locative)))
-\f
-(define-integrable r0 0)
-(define-integrable r1 1)
-(define-integrable r2 2)
-(define-integrable r3 3)
-(define-integrable r4 4)
-(define-integrable r5 5)
-(define-integrable r6 6)
-(define-integrable r7 7)
-(define-integrable r8 8)
-(define-integrable r9 9)
-(define-integrable r10 10)
-(define-integrable r11 11)
-(define-integrable r12 12)
-(define-integrable r13 13)
-(define-integrable r14 14)
-(define-integrable r15 15)
-(define-integrable r16 16)
-(define-integrable r17 17)
-(define-integrable r18 18)
-(define-integrable r19 19)
-(define-integrable r20 20)
-(define-integrable r21 21)
-(define-integrable r22 22)
-(define-integrable r23 23)
-(define-integrable r24 24)
-(define-integrable r25 25)
-(define-integrable r26 26)
-(define-integrable r27 27)
-(define-integrable r28 28)
-(define-integrable r29 29)
-(define-integrable r30 30)
-(define-integrable r31 31)
-
-(define number-of-machine-registers 32)
-
-(define-integrable (sort-machine-registers registers)
- registers)
-
-(define (pseudo-register=? x y)
- (= (register-renumber x) (register-renumber y)))
-
-(define available-machine-registers
- (list r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 r16 r17 r18
- r19 r20 r21 r22))
-
-(define-integrable (register-contains-address? register)
- (memv register '(23 24 25 30)))
-
-(define-integrable (register-type register)
- false)
-
-(define-integrable (register-reference register)
- register)
-\f
-(define-integrable regnum:frame-size r3)
-(define-integrable regnum:call-argument-0 r4)
-(define-integrable regnum:call-argument-1 r5)
-(define-integrable regnum:call-argument-2 r6)
-(define-integrable regnum:call-value r28)
-
-(define-integrable regnum:memtop-pointer r23)
-(define-integrable regnum:regs-pointer r24)
-(define-integrable regnum:free-pointer r25)
-(define-integrable regnum:code-object-base r26)
-(define-integrable regnum:address-offset r27)
-(define-integrable regnum:stack-pointer r30)
-
-(define-integrable (interpreter-register:access)
- (rtl:make-machine-register regnum:call-value))
-
-(define-integrable (interpreter-register:enclose)
- (rtl:make-machine-register regnum:call-value))
-
-(define-integrable (interpreter-register:lookup)
- (rtl:make-machine-register regnum:call-value))
-
-(define-integrable (interpreter-register:unassigned?)
- (rtl:make-machine-register regnum:call-value))
-
-(define-integrable (interpreter-register:unbound?)
- (rtl:make-machine-register regnum:call-value))
-
-(define-integrable (interpreter-free-pointer)
- (rtl:make-machine-register regnum:free-pointer))
-
-(define-integrable (interpreter-free-pointer? register)
- (= (rtl:register-number register) regnum:free-pointer))
-
-(define-integrable (interpreter-regs-pointer)
- (rtl:make-machine-register regnum:regs-pointer))
-
-(define-integrable (interpreter-regs-pointer? register)
- (= (rtl:register-number register) regnum:regs-pointer))
-
-(define-integrable (interpreter-stack-pointer)
- (rtl:make-machine-register regnum:stack-pointer))
-
-(define-integrable (interpreter-stack-pointer? register)
- (= (rtl:register-number register) regnum:stack-pointer))
-\f
-(define (lap:make-label-statement label)
- `(LABEL ,label))
-
-(define (lap:make-unconditional-branch label)
- `((BL (N) (- (- ,label *PC*) 8) 0)))
-
-(define (lap:make-entry-point label block-start-label)
- `((ENTRY-POINT ,label)
- (WORD (- ,label ,block-start-label))
- (LABEL ,label)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 1.3 1987/03/19 00:56:02 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Compiler Make File for HP Precision Architecture
-
-(declare (usual-integrations))
-\f
-(set-working-directory-pathname! "$zcomp")
-(load "rcs" system-global-environment)
-(load "load" system-global-environment)
-
-(load-system system-global-environment
- 'COMPILER-PACKAGE
- '(SYSTEM-GLOBAL-ENVIRONMENT)
- '(
- (SYSTEM-GLOBAL-ENVIRONMENT
- "macros.bin" ;compiler syntax
- "pbs.bin" ;bit-string read/write syntax
- )
-
- (COMPILER-PACKAGE
- "spectrum/machin.bin" ;machine dependent stuff
- "toplev.bin" ;top level
- "utils.bin" ;odds and ends
- "cfg.bin" ;control flow graph
- "ctypes.bin" ;CFG datatypes
- "dtypes.bin" ;DFG datatypes
- "bblock.bin" ;Basic block datatype
- "dfg.bin" ;data flow graph
- "rtl.bin" ;register transfer language
- "emodel.bin" ;environment model
- "rtypes.bin" ;RTL analyzer datatypes
- "nmatch.bin" ;simple pattern matcher
- )
-
- (CONVERTER-PACKAGE
- "graphc.bin" ;SCode->flow-graph converter
- )
-
- (DATAFLOW-PACKAGE
- "dflow.bin" ;Dataflow analyzer
- )
-
- (RTL-GENERATOR-PACKAGE
- "rtlgen.bin" ;RTL generator
- "rgcomb.bin" ;RTL generator: combinations
- "linear.bin" ;linearization
- )
-
- (RTL-CSE-PACKAGE
- "rcse.bin" ;RTL common subexpression eliminator
- )
-
- (RTL-ANALYZER-PACKAGE
- "rlife.bin" ;RTL register lifetime analyzer
- "ralloc.bin" ;RTL register allocator
- )
-
- (LAP-GENERATOR-PACKAGE
- "lapgen.bin" ;LAP generator.
- "regmap.bin" ;Hardware register allocator.
- "spectrum/lapgen.bin" ;code generation rules.
- )
-
- (LAP-SYNTAXER-PACKAGE
- "syntax.bin" ;Generic syntax phase
- "spectrum/insutl.bin" ;Utilities for spectrum
- "spectrum/coerce.bin" ;Coercions: integer -> bit string
- "asmmac.bin" ;Macros for hairy syntax
- "spectrum/instrs.bin" ;Spectrum instructions
- )
-
- (LAP-PACKAGE
- "spectrum/assmd.bin" ;Machine dependent
- "symtab.bin" ;Symbol tables
- "block.bin" ;Assembly blocks
- "laptop.bin" ;Assembler top level
- "spectrum/asmops.bin" ;Spectrum assembly operators
- )
-
- ))
-
-(in-package compiler-package
-
- (define compiler-system
- (make-environment
- (define :name "Liar (Spectrum)")
- (define :version)
- (define :modification)
-
- (parse-rcs-header "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 1.3 1987/03/19 00:56:02 cph Exp $"
- (lambda (filename version date time author state)
- (set! :version (car version))
- (set! :modification (cadr version))))))
-
- (add-system! compiler-system))
-
-(%ge compiler-package)
-(%gst (access compiler-syntax-table compiler-package))
-(disk-save "$zcomp/machines/spectrum/compiler")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.1 1987/03/19 00:44:34 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL CFG Nodes
-
-(declare (usual-integrations))
-\f
-;;; Hack to make RNODE-RTL, etc, work on both types of node.
-
-(define-snode rtl-snode)
-(define-pnode rtl-pnode)
-(define-vector-slots rnode 7 rtl dead-registers logical-link register-map lap)
-(define-vector-slots rtl-pnode 12 consequent-lap-generator
- alternative-lap-generator)
-
-(define-integrable (statement->snode statement)
- (make-pnode rtl-snode-tag statement '() false false false))
-
-(define-integrable (statement->scfg statement)
- (snode->scfg (statement->snode statement)))
-
-(define-integrable (predicate->pnode predicate)
- (make-pnode rtl-pnode-tag predicate '() false false false false false))
-
-(define-integrable (predicate->pcfg predicate)
- (pnode->pcfg (predicate->pnode predicate)))
-
-(define-integrable (rnode-dead-register? rnode register)
- (memv register (rnode-dead-registers rnode)))
-
-(let ((rnode-describe
- (lambda (rnode)
- `((RNODE-RTL ,(rnode-rtl rnode))
- (RNODE-DEAD-REGISTERS ,(rnode-dead-registers rnode))
- (RNODE-LOGICAL-LINK ,(rnode-logical-link rnode))
- (RNODE-REGISTER-MAP ,(rnode-register-map rnode))
- (RNODE-LAP ,(rnode-lap rnode))))))
-
- (define-vector-method rtl-snode-tag ':DESCRIBE
- (lambda (snode)
- (append! ((vector-tag-method snode-tag ':DESCRIBE) snode)
- (rnode-describe snode))))
-
- (define-vector-method rtl-pnode-tag ':DESCRIBE
- (lambda (pnode)
- (append! ((vector-tag-method pnode-tag ':DESCRIBE) pnode)
- (rnode-describe pnode)
- `((RTL-PNODE-CONSEQUENT-LAP-GENERATOR
- ,(rtl-pnode-consequent-lap-generator pnode))
- (RTL-PNODE-ALTERNATIVE-LAP-GENERATOR
- ,(rtl-pnode-alternative-lap-generator pnode)))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 1.1 1987/03/19 00:44:37 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Registers
-
-(declare (usual-integrations))
-\f
-(define machine-register-map
- (make-vector number-of-machine-registers))
-
-(let loop ((n 0))
- (if (< n number-of-machine-registers)
- (begin (vector-set! machine-register-map n (%make-register n))
- (loop (1+ n)))))
-
-(define-integrable (rtl:make-machine-register n)
- (vector-ref machine-register-map n))
-
-(define *next-pseudo-number*)
-(define *temporary->register-map*)
-
-(define (rtl:make-pseudo-register)
- (let ((n *next-pseudo-number*))
- (set! *next-pseudo-number* (1+ *next-pseudo-number*))
- (%make-register n)))
-
-(define (temporary->register temporary)
- (let ((entry (assq temporary *temporary->register-map*)))
- (if entry
- (cdr entry)
- (let ((register (rtl:make-pseudo-register)))
- (set! *temporary->register-map*
- (cons (cons temporary register)
- *temporary->register-map*))
- register))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.2 1987/04/12 00:21:39 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Register Transfer Language Type Definitions
-
-(declare (usual-integrations))
-\f
-(define-rtl-expression register % number)
-(define-rtl-expression object->address rtl: register)
-(define-rtl-expression object->datum rtl: register)
-(define-rtl-expression object->type rtl: register)
-(define-rtl-expression offset rtl: register number)
-(define-rtl-expression pre-increment rtl: register number)
-(define-rtl-expression post-increment rtl: register number)
-
-(define-rtl-expression cons-pointer rtl: type datum)
-(define-rtl-expression constant rtl: value)
-(define-rtl-expression entry:continuation rtl: continuation)
-(define-rtl-expression entry:procedure rtl: procedure)
-(define-rtl-expression offset-address rtl: register number)
-(define-rtl-expression unassigned rtl:)
-
-(define-rtl-predicate eq-test % expression-1 expression-2)
-(define-rtl-predicate true-test % expression)
-(define-rtl-predicate type-test % expression type)
-(define-rtl-predicate unassigned-test % expression)
-
-(define-rtl-statement assign % address expression)
-(define-rtl-statement continuation-heap-check rtl: continuation)
-(define-rtl-statement procedure-heap-check rtl: procedure)
-(define-rtl-statement return rtl:)
-(define-rtl-statement setup-lexpr rtl: procedure)
-
-(define-rtl-statement interpreter-call:access % environment name)
-(define-rtl-statement interpreter-call:define % environment name value)
-(define-rtl-statement interpreter-call:enclose rtl: size)
-(define-rtl-statement interpreter-call:lookup % environment name)
-(define-rtl-statement interpreter-call:set! % environment name value)
-(define-rtl-statement interpreter-call:unassigned? % environment name)
-(define-rtl-statement interpreter-call:unbound? % environment name)
-
-(define-rtl-statement invocation:apply rtl: pushed prefix continuation)
-(define-rtl-statement invocation:jump % pushed prefix continuation procedure)
-(define-rtl-statement invocation:lexpr rtl: pushed prefix continuation
- procedure)
-(define-rtl-statement invocation:lookup % pushed prefix continuation
- environment name)
-(define-rtl-statement invocation:primitive rtl: pushed prefix continuation
- procedure)
-
-(define-rtl-statement message-sender:value rtl: size)
-(define-rtl-statement message-receiver:closure rtl: size)
-(define-rtl-statement message-receiver:stack rtl: size)
-(define-rtl-statement message-receiver:subproblem rtl: continuation)
-
-(define-integrable rtl:expression-type first)
-(define-integrable rtl:address-register second)
-(define-integrable rtl:address-number third)
-(define-integrable rtl:invocation-pushed second)
-(define-integrable rtl:invocation-prefix third)
-(define-integrable rtl:invocation-continuation fourth)
-(define-integrable rtl:test-expression second)
-\f
-;;;; Locatives
-
-;;; Locatives are used as an intermediate form by the code generator
-;;; to build expressions. Later, when the expressions are inserted
-;;; into statements, any locatives they contain are eliminated by
-;;; "simplifying" them into sequential instructions using pseudo
-;;; registers.
-
-(define-integrable register:environment
- 'ENVIRONMENT)
-
-(define-integrable register:stack-pointer
- 'STACK-POINTER)
-
-(define-integrable register:value
- 'VALUE)
-
-(define-integrable (rtl:interpreter-call-result:access)
- (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
-
-(define-integrable (rtl:interpreter-call-result:enclose)
- (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ENCLOSE))
-
-(define-integrable (rtl:interpreter-call-result:lookup)
- (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP))
-
-(define-integrable (rtl:interpreter-call-result:unassigned?)
- (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?))
-
-(define-integrable (rtl:interpreter-call-result:unbound?)
- (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))
-
-(define (rtl:locative-offset locative offset)
- (cond ((zero? offset) locative)
- ((and (pair? locative) (eq? (car locative) 'OFFSET))
- `(OFFSET ,(cadr locative) ,(+ (caddr locative) offset)))
- (else `(OFFSET ,locative ,offset))))
-
-;;; Expressions that are used in the intermediate form.
-
-(define-integrable (rtl:make-fetch locative)
- `(FETCH ,locative))
-
-(define-integrable (rtl:make-address locative)
- `(ADDRESS ,locative))
-
-(define-integrable (rtl:make-cell-cons expression)
- `(CELL-CONS ,expression))
-
-(define-integrable (rtl:make-typed-cons:pair type car cdr)
- `(TYPED-CONS:PAIR ,type ,car ,cdr))
-\f
-;;; Linearizer Support
-
-(define-integrable (rtl:make-jump-statement label)
- `(JUMP ,label))
-
-(define-integrable (rtl:make-jumpc-statement predicate label)
- `(JUMPC ,predicate ,label))
-
-(define-integrable (rtl:make-label-statement label)
- `(LABEL ,label))
-
-(define-integrable (rtl:negate-predicate expression)
- `(NOT ,expression))
-
-;;; Stack
-
-(define-integrable (stack-locative-offset locative offset)
- (rtl:locative-offset locative (stack->memory-offset offset)))
-
-(define-integrable (stack-push-address)
- (rtl:make-pre-increment (interpreter-stack-pointer)
- (stack->memory-offset -1)))
-
-(define-integrable (stack-pop-address)
- (rtl:make-post-increment (interpreter-stack-pointer)
-(define-rtl-statement message-receiver:subproblem % continuation)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.9 1987/04/17 07:46:08 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Generation: Combinations
-
-(declare (usual-integrations))
-\f
-(define-generator combination-tag
- (lambda (combination offset rest-generator)
- ((cond ((combination-constant? combination) combination:constant)
- ((let ((operator (combination-known-operator combination)))
- (and operator
- (normal-primitive-constant? operator)))
- combination:primitive)
- (else combination:normal))
- combination offset rest-generator)))
-
-(define (combination:normal combination offset rest-generator)
- ;; For the time being, all close-coded combinations will return
- ;; their values in the value register. If the value of a
- ;; combination is not a temporary, it is a value-ignore, which is
- ;; alright.
- (let ((value (combination-value combination)))
- (if (temporary? value)
- (let ((type (temporary-type value)))
- (if type
- (if (not (eq? 'VALUE type))
- (error "COMBINATION:NORMAL: Bad temporary type" type))
- (set-temporary-type! value 'VALUE)))))
- (if (generate:next-is-null? (snode-next combination) rest-generator)
- (combination:reduction combination offset)
- (combination:subproblem combination offset rest-generator)))
-
-(define (combination:constant combination offset rest-generator)
- (let ((value (combination-value combination))
- (next (snode-next combination)))
- (cond ((value-temporary? value)
- (generate-assignment (combination-block combination)
- value
- (combination-constant-value combination)
- next
- offset
- rest-generator
- rvalue->sexpression))
- ((value-ignore? value)
- (generate:next next offset rest-generator))
- (else (error "Unknown combination value" value)))))
-
-(define (combination:primitive combination offset rest-generator)
- (let ((open-coder
- (assq (constant-value (combination-known-operator combination))
- primitive-open-coders)))
- (or (and open-coder
- ((cdr open-coder) combination offset rest-generator))
- (combination:normal combination offset rest-generator))))
-\f
-(define (define-open-coder primitive open-coder)
- (let ((entry (assq primitive primitive-open-coders)))
- (if entry
- (set-cdr! entry open-coder)
- (set! primitive-open-coders
- (cons (cons primitive open-coder)
- primitive-open-coders))))
- primitive)
-
-(define primitive-open-coders
- '())
-
-(define-open-coder pair?
- (lambda (combination offset rest-generator)
- (and (combination-compiled-for-predicate? combination)
- (open-code:type-test combination offset rest-generator
- (ucode-type pair) 0))))
-
-(define-open-coder primitive-type?
- (lambda (combination offset rest-generator)
- (and (combination-compiled-for-predicate? combination)
- (operand->index combination 0
- (lambda (type)
- (open-code:type-test combination offset rest-generator
- type 1))))))
-
-(define (open-code:type-test combination offset rest-generator type operand)
- (let ((next (snode-next combination))
- (operand (list-ref (combination-operands combination) operand)))
- (generate:subproblem operand offset
- (lambda (offset)
- (generate:predicate next offset rest-generator
- (rvalue->pexpression (subproblem-value operand) offset
- (lambda (expression)
- (rtl:make-type-test (rtl:make-object->type expression)
- type))))))))
-
-(define-integrable (combination-compiled-for-predicate? combination)
- (eq? 'PREDICATE (combination-compilation-type combination)))
-\f
-(define-open-coder car
- (lambda (combination offset rest-generator)
- (open-code:memory-reference combination offset rest-generator 0)))
-
-(define-open-coder cdr
- (lambda (combination offset rest-generator)
- (open-code:memory-reference combination offset rest-generator 1)))
-
-(define-open-coder cell-contents
- (lambda (combination offset rest-generator)
- (open-code:memory-reference combination offset rest-generator 0)))
-
-(define-open-coder vector-length
- (lambda (combination offset rest-generator)
- (open-code-expression-1 combination offset rest-generator
- (lambda (operand)
- (rtl:make-cons-pointer
- (rtl:make-constant (ucode-type fixnum))
- (rtl:make-fetch (rtl:locative-offset operand 0)))))))
-
-(define-open-coder vector-ref
- (lambda (combination offset rest-generator)
- (operand->index combination 1
- (lambda (index)
- (open-code:memory-reference combination offset rest-generator
- (1+ index))))))
-
-(define (open-code:memory-reference combination offset rest-generator index)
- (open-code-expression-1 combination offset rest-generator
- (lambda (operand)
- (rtl:make-fetch (rtl:locative-offset operand index)))))
-
-(define (open-code-expression-1 combination offset rest-generator receiver)
- (let ((operand (car (combination-operands combination))))
- (generate:subproblem operand offset
- (lambda (offset)
- (generate-assignment (combination-block combination)
- (combination-value combination)
- (subproblem-value operand)
- (snode-next combination)
- offset
- rest-generator
- (lambda (rvalue offset receiver*)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (receiver* (receiver expression))))))))))
-
-(define (operand->index combination n receiver)
- (let ((operand (list-ref (combination-operands combination) n)))
- (and (subproblem-known-constant? operand)
- (let ((value (subproblem-constant-value operand)))
- (and (integer? value)
- (not (negative? value))
- (receiver value))))))
-\f
-;;;; Subproblems
-
-(define (combination:subproblem combination offset rest-generator)
- (let ((block (combination-block combination))
- (finish
- (lambda (offset delta call-prefix continuation-prefix)
- (let ((continuation (make-continuation delta)))
- (set-continuation-rtl-entry!
- continuation
- (scfg*node->node!
- (scfg*scfg->scfg!
- (rtl:make-continuation-heap-check continuation)
- continuation-prefix)
- (generate:next (snode-next combination) offset rest-generator)))
- (scfg*node->node! (call-prefix continuation)
- (combination:subproblem-body combination
- (+ offset delta)
- continuation))))))
- (cond ((ic-block? block)
- ;; **** Actually, should only do this if the environment
- ;; will be needed by the continuation.
- (finish (1+ offset) 1
- (lambda (continuation)
- (scfg*scfg->scfg!
- (rtl:make-push (rtl:make-fetch register:environment))
- (rtl:make-push-return continuation)))
- (rtl:make-pop register:environment)))
- ((and (stack-block? block)
- (let ((operator (combination-known-operator combination)))
- (and operator
- (procedure? operator)
- (procedure/open-internal? operator))))
- (finish offset
- (rtl:message-receiver-size:subproblem)
- rtl:make-message-receiver:subproblem
- (make-null-cfg)))
- (else
- (finish offset 1 rtl:make-push-return (make-null-cfg))))))
-
-(define (combination:subproblem-body combination offset continuation)
- ((let ((operator (combination-known-operator combination)))
- (cond ((normal-primitive-constant? operator) make-call:primitive)
- ((or (not operator) (not (procedure? operator))) make-call:unknown)
- (else
- (case (procedure/type operator)
- ((OPEN-INTERNAL) make-call:stack-with-link)
- ((OPEN-EXTERNAL) make-call:open-external)
- ((CLOSURE) make-call:closure)
- ((IC) make-call:ic)
- (else (error "Unknown callee type" operator))))))
- combination offset invocation-prefix:null continuation))
-\f
-;;;; Reductions
-
-(define (combination:reduction combination offset)
- (let ((callee (combination-known-operator combination))
- (block (combination-block combination)))
- (define (choose-generator ic external internal)
- ((let ((caller (block-procedure block)))
- (cond ((or (not caller) (procedure/ic? caller)) ic)
- ((procedure/external? caller) external)
- (else internal)))
- combination offset))
- (cond ((normal-primitive-constant? callee)
- (choose-generator reduction:ic->primitive
- reduction:external->primitive
- reduction:internal->primitive))
- ((or (not callee)
- (not (procedure? callee)))
- (choose-generator reduction:ic->unknown
- reduction:external->unknown
- reduction:internal->unknown))
- (else
- (case (procedure/type callee)
- ((IC)
- (choose-generator reduction:ic->ic
- reduction:external->ic
- reduction:internal->ic))
- ((CLOSURE)
- (choose-generator reduction:ic->closure
- reduction:external->closure
- reduction:internal->closure))
- ((OPEN-EXTERNAL)
- (choose-generator reduction:ic->open-external
- reduction:external->open-external
- reduction:internal->open-external))
- ((OPEN-INTERNAL)
- (choose-generator reduction:ic->child
- reduction:external->child
- (let ((block* (procedure-block callee)))
- (cond ((block-child? block block*)
- reduction:internal->child)
- ((block-sibling? block block*)
- reduction:internal->sibling)
- (else
- reduction:internal->ancestor)))))
- (else (error "Unknown callee type" callee)))))))
-\f
-(define (reduction:ic->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:null false))
-
-(define (reduction:ic->ic combination offset)
- (make-call:ic combination offset invocation-prefix:null false))
-
-(define (reduction:ic->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:null false))
-
-(define (reduction:ic->closure combination offset)
- (make-call:closure combination offset invocation-prefix:null false))
-
-(define (reduction:ic->open-external combination offset)
- (make-call:open-external combination offset invocation-prefix:null false))
-
-(define (reduction:ic->child combination offset)
- (error "Calling internal procedure from IC procedure"))
-
-(define (reduction:external->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:move-frame-up false))
-
-(define (reduction:external->ic combination offset)
- (make-call:ic combination offset invocation-prefix:move-frame-up false))
-
-(define (reduction:external->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:move-frame-up
- false))
-
-(define (reduction:external->closure combination offset)
- (make-call:closure combination offset invocation-prefix:move-frame-up false))
-
-(define (reduction:external->open-external combination offset)
- (make-call:open-external combination offset invocation-prefix:move-frame-up
- false))
-
-(define (reduction:external->child combination offset)
- (make-call:child combination offset
- rtl:make-message-receiver:closure
- rtl:message-receiver-size:closure))
-\f
-(define (reduction:internal->unknown combination offset)
- (make-call:unknown combination offset invocation-prefix:internal->closure
- false))
-
-(define (reduction:internal->ic combination offset)
- (make-call:ic combination offset invocation-prefix:internal->closure false))
-
-(define (reduction:internal->primitive combination offset)
- (make-call:primitive combination offset invocation-prefix:internal->closure
- false))
-
-(define (reduction:internal->closure combination offset)
- (make-call:closure combination offset invocation-prefix:internal->closure
- false))
-
-(define (reduction:internal->open-external combination offset)
- (make-call:open-external combination offset
- invocation-prefix:internal->closure
- false))
-
-(define (reduction:internal->child combination offset)
- (make-call:child combination offset
- rtl:make-message-receiver:stack
- rtl:message-receiver-size:stack))
-
-(define (reduction:internal->sibling combination offset)
- (make-call:stack combination offset invocation-prefix:internal->sibling
- false))
-
-(define (reduction:internal->ancestor combination offset)
- (make-call:stack-with-link combination offset
- invocation-prefix:internal->ancestor false))
-\f
-;;;; Calls
-
-(define (make-call:apply combination offset invocation-prefix continuation)
- (make-call:push-operator combination offset
- (lambda (number-pushed)
- (rtl:make-invocation:apply number-pushed
- (invocation-prefix combination number-pushed)
- continuation))))
-
-(define (make-call:lookup combination offset invocation-prefix continuation)
- (make-call:dont-push-operator combination offset
- (lambda (number-pushed)
- (let ((operator (subproblem-value (combination-operator combination))))
- (let ((block (reference-block operator))
- (name (variable-name (reference-variable operator))))
- (rtl:make-invocation:lookup
- number-pushed
- (invocation-prefix combination number-pushed)
- continuation
- (nearest-ic-block-expression block (+ offset number-pushed))
- (intern-scode-variable! block name)))))))
-
-(define (make-call:unknown combination offset invocation-prefix continuation)
- (let ((operator (subproblem-value (combination-operator combination))))
- ((cond ((or (not (reference? operator))
- (reference-to-known-location? operator))
- make-call:apply)
- ;; **** Need to add code for links here.
- (else make-call:lookup))
- combination offset invocation-prefix continuation)))
-
-;;; For now, use apply. Later we can optimize for the cases where
-;;; the callee's closing frame is easily available, such as calling a
-;;; sibling, self-recursion, or an ancestor.
-
-(define make-call:ic make-call:apply)
-
-(define (make-call:primitive combination offset invocation-prefix continuation)
- (make-call:dont-push-operator combination offset
- (lambda (number-pushed)
- (rtl:make-invocation:primitive
- number-pushed
- (invocation-prefix combination number-pushed)
- continuation
- (constant-value (combination-known-operator combination))))))
-\f
-(define (make-call:closure combination offset invocation-prefix continuation)
- (make-call:push-operator combination offset
- (external-call combination invocation-prefix continuation)))
-
-(define (make-call:open-external combination offset invocation-prefix
- continuation)
- (scfg*node->node!
- (rtl:make-push (rtl:make-fetch register:environment))
- (make-call:dont-push-operator combination offset
- (external-call combination invocation-prefix continuation))))
-
-(define (external-call combination invocation-prefix continuation)
- (lambda (number-pushed)
- (let ((operator (combination-known-operator combination)))
- ((if (procedure-rest operator)
- rtl:make-invocation:lexpr
- rtl:make-invocation:jump)
- number-pushed
- (invocation-prefix combination number-pushed)
- continuation
- operator))))
-\f
-(package (make-call:stack make-call:stack-with-link make-call:child)
-
-(define-export (make-call:stack combination offset invocation-prefix
- continuation)
- (stack-call combination offset invocation-prefix continuation 0))
-
-(define-export (make-call:stack-with-link combination offset invocation-prefix
- continuation)
- (link-call combination offset invocation-prefix continuation 0))
-
-(define-export (make-call:child combination offset make-receiver receiver-size)
- (scfg*node->node!
- (make-receiver (block-frame-size (combination-block combination)))
- (let ((extra (receiver-size)))
- (link-call combination (+ offset extra) invocation-prefix:null false
- extra))))
-
-(define (link-call combination offset invocation-prefix continuation extra)
- (scfg*node->node!
- (rtl:make-push
- (rtl:make-address
- (block-ancestor-or-self->locative
- (combination-block combination)
- (block-parent (procedure-block (combination-known-operator combination)))
- offset)))
- (stack-call combination (1+ offset) invocation-prefix continuation
- (1+ extra))))
-
-(define (stack-call combination offset invocation-prefix continuation extra)
- (make-call:dont-push-operator combination offset
- (lambda (number-pushed)
- (let ((number-pushed (+ number-pushed extra))
- (operator (combination-known-operator combination)))
- ((if (procedure-rest operator)
- rtl:make-invocation:lexpr
- rtl:make-invocation:jump)
- number-pushed
- (invocation-prefix combination number-pushed)
- continuation
- operator)))))
-
-)
-\f
-;;;; Prefixes
-
-(define (invocation-prefix:null combination number-pushed)
- '(NULL))
-
-(define (invocation-prefix:move-frame-up combination number-pushed)
- `(MOVE-FRAME-UP ,number-pushed
- ,(block-frame-size (combination-block combination))))
-
-(define (invocation-prefix:internal->closure combination number-pushed)
- ;; The message sender will shift the new stack frame down to the
- ;; correct position when it is done, then reset the stack pointer.
- `(APPLY-CLOSURE ,number-pushed
- ,(+ number-pushed
- (block-frame-size (combination-block combination)))))
-
-(define (invocation-prefix:internal->ancestor combination number-pushed)
- (let ((block (combination-block combination)))
- `(APPLY-STACK ,number-pushed
- ,(+ number-pushed (block-frame-size block))
- ,(block-ancestor-distance
- block
- (block-parent
- (procedure-block
- (combination-known-operator combination)))))))
-
-(define (invocation-prefix:internal->sibling combination number-pushed)
- `(MOVE-FRAME-UP ,number-pushed
- ;; -1+ means reuse the existing static link.
- ,(-1+ (block-frame-size (combination-block combination)))))
-\f
-;;;; Call Sequence Kernels
-
-(package (make-call:dont-push-operator make-call:push-operator)
-
-(define (make-call-maker generate:operator wrap-n)
- (lambda (combination offset make-invocation)
- (let ((operator (combination-known-operator combination))
- (operands (combination-operands combination)))
- (let ((n-operands (length operands))
- (finish
- (lambda (n offset)
- (let operand-loop
- ((operands (reverse operands))
- (offset offset))
- (if (null? operands)
- (generate:operator (combination-operator combination)
- offset
- (lambda (offset)
- (cfg-entry-node (make-invocation (wrap-n n)))))
- (subproblem->push (car operands) offset
- (lambda (offset)
- (operand-loop (cdr operands) offset))))))))
- (if (and operator
- (procedure? operator)
- (not (procedure-rest operator))
- (stack-block? (procedure-block operator)))
- (let ((n-parameters (+ (length (procedure-required operator))
- (length (procedure-optional operator)))))
- (let ((delta (- n-parameters n-operands)))
- (scfg*scfg->scfg! (scfg*->scfg! (push-n-unassigned delta))
- (finish n-parameters (+ offset delta)))))
- (finish n-operands offset))))))
-
-(define (push-n-unassigned n)
- (if (zero? n)
- '()
- (cons (rtl:make-push (rtl:make-unassigned))
- (push-n-unassigned (-1+ n)))))
-
-(define (subproblem->push subproblem offset receiver)
- (generate:subproblem subproblem offset
- (lambda (offset)
- (scfg*node->node!
- (rvalue->sexpression (subproblem-value subproblem) offset rtl:make-push)
- (receiver (1+ offset))))))
-
-(define-export make-call:dont-push-operator
- (make-call-maker generate:subproblem identity-procedure))
-
-(define-export make-call:push-operator
- (make-call-maker subproblem->push 1+))
-
- ,(-1+ (block-frame-size (combination-block combination)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.9 1987/04/12 01:14:46 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Generation
-
-(declare (usual-integrations))
-\f
-(define *nodes*)
-
-(define (generate-rtl quotations procedures)
- (with-new-node-marks
- (lambda ()
- (fluid-let ((*nodes* '()))
- (for-each (lambda (quotation)
- (set-quotation-rtl-entry!
- quotation
- (generate:top-level (quotation-fg-entry quotation))))
- quotations)
- (for-each generate:procedure procedures)
- (for-each (lambda (rnode)
- (node-property-remove! rnode generate:node))
- *nodes*)))))
-
-(define-integrable (generate:top-level expression)
- (generate:node expression 0 false))
-
-(define (generate:subproblem subproblem offset rest-generator)
- (let ((cfg (subproblem-cfg subproblem)))
- (if (cfg-null? cfg)
- (and rest-generator (rest-generator offset))
- (generate:node (cfg-entry-node cfg) offset rest-generator))))
-
-(define (generate:next node offset rest-generator)
- (cond ((not node) (and rest-generator (rest-generator offset)))
- ((node-marked? node)
- (let ((memo (node-property-get node generate:node)))
- (if (not (= (car memo) offset))
- (error "Node entered at different offsets" node))
- (cdr memo)))
- (else (generate:node node offset rest-generator))))
-
-(define (generate:node node offset rest-generator)
- (node-mark! node)
- (let ((cfg ((vector-method node generate:node) node offset rest-generator)))
- (node-property-put! node generate:node (cons offset cfg))
- (set! *nodes* (cons node *nodes*))
- cfg))
-
-(define-integrable (generate:next-is-null? next rest-generator)
- (and (not next) (not rest-generator)))
-\f
-(define (generate:procedure procedure)
- (set-procedure-rtl-entry!
- procedure
- (let ((body (generate:top-level (procedure-fg-entry procedure))))
- (if (procedure/ic? procedure)
- body
- (scfg*node->node!
- (scfg*scfg->scfg!
- ((if (or (procedure-rest procedure)
- (and (procedure/closure? procedure)
- (not (null? (procedure-optional procedure)))))
- rtl:make-setup-lexpr
- rtl:make-procedure-heap-check)
- procedure)
- (setup-stack-frame procedure))
- body)))))
-
-(define (setup-stack-frame procedure)
- (let ((block (procedure-block procedure)))
- (define (cellify-variables variables)
- (scfg*->scfg! (map cellify-variable variables)))
-
- (define (cellify-variable variable)
- (if (variable-in-cell? variable)
- (let ((locative
- (stack-locative-offset (rtl:make-fetch register:stack-pointer)
- (variable-offset block variable))))
- (rtl:make-assignment
- locative
- (rtl:make-cell-cons (rtl:make-fetch locative))))
- (make-null-cfg)))
-
- (let ((names (procedure-names procedure))
- (values (procedure-values procedure)))
- (scfg-append! (setup-bindings names values '())
- (setup-auxiliary (procedure-auxiliary procedure) '())
- (cellify-variables (procedure-required procedure))
- (cellify-variables (procedure-optional procedure))
- (let ((rest (procedure-rest procedure)))
- (if rest
- (cellify-variable rest)
- (make-null-cfg)))
- (scfg*->scfg!
- (map (lambda (name value)
- (if (and (procedure? value)
- (procedure/closure? value))
- (letrec-close block name value)
- (make-null-cfg)))
- names values))))))
-\f
-(define (setup-bindings names values pushes)
- (if (null? names)
- (scfg*->scfg! pushes)
- (setup-bindings (cdr names)
- (cdr values)
- (cons (make-auxiliary-push (car names)
- (letrec-value (car values)))
- pushes))))
-
-(define (letrec-value value)
- (cond ((constant? value)
- (rtl:make-constant (constant-value value)))
- ((procedure? value)
- (case (procedure/type value)
- ((CLOSURE)
- (make-closure-cons value (rtl:make-constant '())))
- ((IC)
- (make-ic-cons value))
- ((OPEN-EXTERNAL OPEN-INTERNAL)
- (error "Letrec value is open procedure" value))
- (else
- (error "Unknown procedure type" value))))
- (else
- (error "Unknown letrec binding value" value))))
-
-(define (letrec-close block variable value)
- (make-closure-environment value 0 scfg*scfg->scfg!
- (lambda (environment)
- (rtl:make-assignment
- (closure-procedure-environment-locative
- (find-variable block variable 0
- (lambda (locative) locative)
- (lambda (nearest-ic-locative name)
- (error "Missing closure variable" variable))))
- environment))))
-
-(define (setup-auxiliary variables pushes)
- (if (null? variables)
- (scfg*->scfg! pushes)
- (setup-auxiliary (cdr variables)
- (cons (make-auxiliary-push (car variables)
- (rtl:make-unassigned))
- pushes))))
-
-(define (make-auxiliary-push variable value)
- (rtl:make-push (if (variable-in-cell? variable)
- (rtl:make-cell-cons value)
- value)))
-\f
-;;;; Statements
-
-(define (define-generator tag generator)
- (define-vector-method tag generate:node generator))
-
-(define-generator definition-tag
- (lambda (definition offset rest-generator)
- (scfg*node->node!
- (rvalue->sexpression (definition-rvalue definition) offset
- (lambda (expression)
- (find-variable (definition-block definition)
- (definition-lvalue definition)
- offset
- (lambda (locative)
- (error "Definition of compiled variable"))
- (lambda (environment name)
- (rtl:make-interpreter-call:define environment name expression)))))
- (generate:next (snode-next definition) offset rest-generator))))
-
-(define-generator assignment-tag
- (lambda (assignment offset rest-generator)
- (generate-assignment (assignment-block assignment)
- (assignment-lvalue assignment)
- (assignment-rvalue assignment)
- (snode-next assignment)
- offset
- rest-generator
- rvalue->sexpression)))
-
-(define (generate-assignment block lvalue rvalue next offset rest-generator
- rvalue->sexpression)
- ((vector-method lvalue generate-assignment)
- block lvalue rvalue next offset rest-generator rvalue->sexpression))
-
-(define (define-assignment tag generator)
- (define-vector-method tag generate-assignment generator))
-
-(define-assignment variable-tag
- (lambda (block variable rvalue next offset rest-generator
- rvalue->sexpression)
- (scfg*node->node! (if (integrated-vnode? variable)
- (make-null-cfg)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (find-variable block variable offset
- (lambda (locative)
- (rtl:make-assignment locative expression))
- (lambda (environment name)
- (rtl:make-interpreter-call:set!
- environment
- (intern-scode-variable! block name)
- expression))))))
- (generate:next next offset rest-generator))))
-\f
-(define-assignment temporary-tag
- (lambda (block temporary rvalue next offset rest-generator
- rvalue->sexpression)
- (case (temporary-type temporary)
- ((#F)
- (scfg*node->node!
- (if (integrated-vnode? temporary)
- (make-null-cfg)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (rtl:make-assignment temporary expression))))
- (generate:next next offset rest-generator)))
- ((VALUE)
- (assignment:value-register block rvalue next offset
- rest-generator rvalue->sexpression))
- (else
- (error "Unknown temporary type" temporary)))))
-
-(define (assignment:value-register block rvalue next offset
- rest-generator rvalue->sexpression)
- (if (not (generate:next-is-null? next rest-generator))
- (error "Return node has next"))
- (scfg*node->node!
- (scfg*scfg->scfg! (if (value-temporary? rvalue)
- (make-null-cfg)
- (rvalue->sexpression rvalue offset
- (lambda (expression)
- (rtl:make-assignment register:value expression))))
- (if (stack-block? block)
- (if (stack-parent? block)
- (rtl:make-message-sender:value
- (+ offset (block-frame-size block)))
- (scfg*scfg->scfg!
- (rtl:make-pop-frame (block-frame-size block))
- (rtl:make-return)))
- (rtl:make-return)))
- (generate:next next offset rest-generator)))
-
-(define-assignment value-ignore-tag
- (lambda (block value-ignore rvalue next offset rest-generator
- rvalue->sexpression)
- (if (not (generate:next-is-null? next rest-generator))
- (error "Return node has next"))
- (generate:next next offset rest-generator)))
-\f
-;;;; Predicates
-
-(define (define-predicate-generator tag node-generator)
- (define-generator tag
- (lambda (pnode offset rest-generator)
- (generate:predicate pnode offset rest-generator
- (node-generator pnode offset)))))
-
-(define (generate:predicate pnode offset rest-generator pcfg)
- (pcfg*node->node!
- pcfg
- (generate:next (pnode-consequent pnode) offset rest-generator)
- (generate:next (pnode-alternative pnode) offset rest-generator)))
-
-(define-predicate-generator true-test-tag
- (lambda (test offset)
- (let ((rvalue (true-test-rvalue test)))
- (if (rvalue-known-constant? rvalue)
- (constant->pcfg (rvalue-constant-value rvalue))
- (rvalue->pexpression rvalue offset rtl:make-true-test)))))
-
-(define-predicate-generator unassigned-test-tag
- (lambda (test offset)
- (find-variable (unassigned-test-block test)
- (unassigned-test-variable test)
- offset
- (lambda (locative)
- (rtl:make-unassigned-test (rtl:make-fetch locative)))
- (lambda (environment name)
- (scfg*pcfg->pcfg!
- (rtl:make-interpreter-call:unassigned? environment name)
- (rtl:make-true-test (rtl:interpreter-call-result:unassigned?)))))))
-
-(define-predicate-generator unbound-test-tag
- (lambda (test offset)
- (let ((variable (unbound-test-variable test)))
- (if (ic-block? (variable-block variable))
- (scfg*pcfg->pcfg!
- (rtl:make-interpreter-call:unbound?
- (nearest-ic-block-expression (unbound-test-block test) offset)
- (variable-name variable))
- (rtl:make-true-test (rtl:interpreter-call-result:unbound?)))
- (make-false-pcfg)))))
-\f
-;;;; Expressions
-
-(define (rvalue->sexpression rvalue offset receiver)
- (rvalue->expression rvalue offset scfg*scfg->scfg! receiver))
-
-(define (rvalue->pexpression rvalue offset receiver)
- (rvalue->expression rvalue offset scfg*pcfg->pcfg! receiver))
-
-(define (rvalue->expression rvalue offset scfg-append! receiver)
- ((vector-method rvalue rvalue->expression)
- rvalue offset scfg-append! receiver))
-
-(define (define-rvalue->expression tag generator)
- (define-vector-method tag rvalue->expression generator))
-
-(define (constant->expression constant offset scfg-append! receiver)
- (receiver (rtl:make-constant (constant-value constant))))
-
-(define-rvalue->expression constant-tag constant->expression)
-
-(define-rvalue->expression block-tag
- (lambda (block offset scfg-append! receiver)
- (receiver (rtl:make-fetch register:environment))))
-
-(define-rvalue->expression reference-tag
- (lambda (reference offset scfg-append! receiver)
- (reference->expression (reference-block reference)
- (reference-variable reference)
- offset
- scfg-append!
- receiver)))
-
-(define (reference->expression block variable offset scfg-append! receiver)
- (if (vnode-known-constant? variable)
- (constant->expression (vnode-known-value variable) offset scfg-append!
- receiver)
- (find-variable block variable offset
- (lambda (locative)
- (receiver (rtl:make-fetch locative)))
- (lambda (environment name)
- (scfg-append! (rtl:make-interpreter-call:lookup
- environment
- (intern-scode-variable! block name))
- (receiver (rtl:interpreter-call-result:lookup)))))))
-
-(define-rvalue->expression temporary-tag
- (lambda (temporary offset scfg-append! receiver)
- (if (vnode-known-constant? temporary)
- (constant->expression (vnode-known-value temporary) offset scfg-append!
- receiver)
- (let ((type (temporary-type temporary)))
- (cond ((not type) (receiver (rtl:make-fetch temporary)))
- ((eq? type 'VALUE) (receiver (rtl:make-fetch register:value)))
- (else (error "Illegal temporary reference" type)))))))
-\f
-(define-rvalue->expression access-tag
- (lambda (*access offset scfg-append! receiver)
- (rvalue->expression (access-environment *access) offset scfg-append!
- (lambda (expression)
- (scfg-append! (rtl:make-interpreter-call:access expression
- (access-name *access))
- (receiver (rtl:interpreter-call-result:access)))))))
-
-(define-rvalue->expression procedure-tag
- (lambda (procedure offset scfg-append! receiver)
- (case (procedure/type procedure)
- ((CLOSURE)
- (make-closure-environment procedure offset scfg-append!
- (lambda (environment)
- (receiver (make-closure-cons procedure environment)))))
- ((IC)
- (receiver (make-ic-cons procedure)))
- ((OPEN-EXTERNAL OPEN-INTERNAL)
- (error "Reference to open procedure" procedure))
- (else
- (error "Unknown procedure type" procedure)))))
-
-(define (make-ic-cons procedure)
- ;; IC procedures have their entry points linked into their headers
- ;; at load time by the linker.
- (let ((header
- (scode/make-lambda (variable-name (procedure-name procedure))
- (map variable-name (procedure-required procedure))
- (map variable-name (procedure-optional procedure))
- (let ((rest (procedure-rest procedure)))
- (and rest (variable-name rest)))
- (map variable-name
- (append (procedure-auxiliary procedure)
- (procedure-names procedure)))
- '()
- false)))
- (set! *ic-procedure-headers*
- (cons (cons procedure header)
- *ic-procedure-headers*))
- (rtl:make-typed-cons:pair
- (rtl:make-constant (scode/procedure-type-code header))
- (rtl:make-constant header)
- ;; Is this right if the procedure is being closed
- ;; inside another IC procedure?
- (rtl:make-fetch register:environment))))
-\f
-(define (make-closure-environment procedure offset scfg-append! receiver)
- (let ((block (block-parent (procedure-block procedure))))
- (define (ic-locative closure-block block offset)
- (let ((loser
- (lambda (locative)
- (error "Closure parent not IC block"))))
- (find-block closure-block block offset loser loser
- (lambda (locative nearest-ic-locative) locative))))
- (cond ((not block)
- (receiver (rtl:make-constant false)))
- ((ic-block? block)
- (receiver
- (let ((closure-block (procedure-closure-block procedure)))
- (if (ic-block? closure-block)
- (rtl:make-fetch register:environment)
- (ic-locative closure-block block offset)))))
- ((closure-block? block)
- (let ((closure-block (procedure-closure-block procedure)))
- (define (loop variables n receiver)
- (if (null? variables)
- (receiver offset n '())
- (loop (cdr variables) (1+ n)
- (lambda (offset n pushes)
- (receiver (1+ offset) n
- (cons (rtl:make-push
- (rtl:make-fetch
- (find-closure-variable closure-block
- (car variables)
- offset)))
- pushes))))))
-
- (define (make-frame n pushes)
- (scfg-append! (scfg*->scfg!
- (reverse!
- (cons (rtl:make-interpreter-call:enclose n)
- pushes)))
- (receiver (rtl:interpreter-call-result:enclose))))
-
- (loop (block-bound-variables block) 0
- (lambda (offset n pushes)
- (let ((parent (block-parent block)))
- (if parent
- (make-frame (1+ n)
- (cons (rtl:make-push
- (ic-locative closure-block parent
- offset))
- pushes))
- (make-frame n pushes)))))))
- (else (error "Unknown block type" block)))))
-
-(define (make-closure-cons procedure environment)
- (rtl:make-typed-cons:pair (rtl:make-constant type-code:compiled-procedure)
- (rtl:make-entry:procedure procedure)
- "node rtl arguments")
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.10 1987/03/19 00:46:34 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Register Allocation
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define (register-allocation bblocks)
- ;; First, renumber all the registers remaining to be allocated.
- (let ((next-renumber 0)
- (register->renumber (make-vector *n-registers* false)))
- (define (renumbered-registers n)
- (if (< n *n-registers*)
- (if (vector-ref register->renumber n)
- (cons n (renumbered-registers (1+ n)))
- (renumbered-registers (1+ n)))
- '()))
- (for-each-pseudo-register
- (lambda (register)
- (if (positive? (register-n-refs register))
- (begin (vector-set! register->renumber register next-renumber)
- (set! next-renumber (1+ next-renumber))))))
- ;; Now create a conflict matrix for those registers and fill it.
- (let ((conflict-matrix
- (make-initialized-vector next-renumber
- (lambda (i)
- (make-regset next-renumber)))))
- (for-each (lambda (bblock)
- (let ((live (make-regset next-renumber)))
- (for-each-regset-member (bblock-live-at-entry bblock)
- (lambda (register)
- (let ((renumber
- (vector-ref register->renumber register)))
- (if renumber
- (regset-adjoin! live renumber)))))
- (bblock-walk-forward bblock
- (lambda (rnode next)
- (for-each-regset-member live
- (lambda (renumber)
- (regset-union! (vector-ref conflict-matrix
- renumber)
- live)))
- (for-each (lambda (register)
- (let ((renumber
- (vector-ref register->renumber
- register)))
- (if renumber
- (regset-delete! live renumber))))
- (rnode-dead-registers rnode))
- (mark-births! live
- (rnode-rtl rnode)
- register->renumber)))))
- bblocks)
-\f
- ;; Finally, sort the renumbered registers into an allocation
- ;; order, and then allocate them into registers one at a time.
- ;; Return the number of required real registers as a value.
- (let ((next-allocation 0)
- (allocated (make-vector next-renumber 0)))
- (for-each (lambda (register)
- (let ((renumber (vector-ref register->renumber register)))
- (define (loop allocation)
- (if (< allocation next-allocation)
- (if (regset-disjoint?
- (vector-ref conflict-matrix renumber)
- (vector-ref allocated allocation))
- allocation
- (loop (1+ allocation)))
- (let ((allocation next-allocation))
- (set! next-allocation (1+ next-allocation))
- (vector-set! allocated allocation
- (make-regset next-renumber))
- allocation)))
- (let ((allocation (loop 0)))
- (vector-set! *register-renumber* register allocation)
- (regset-adjoin! (vector-ref allocated allocation)
- renumber))))
- (sort (renumbered-registers number-of-machine-registers)
- allocate<?))
- next-allocation))))
-
-(define (allocate<? x y)
- (< (/ (register-n-refs x) (register-live-length x))
- (/ (register-n-refs y) (register-live-length y))))
-
-(define (mark-births! live rtl register->renumber)
- (if (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (if (rtl:register? address)
- (let ((register (rtl:register-number address)))
- (if (pseudo-register? register)
- (regset-adjoin! live
- (vector-ref register->renumber
- register))))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.101 1987/04/12 00:22:23 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Common Subexpression Elimination
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define (common-subexpression-elimination blocks n-registers)
- (fluid-let ((*next-quantity-number* 0))
- (state:initialize n-registers
- (lambda ()
- (for-each walk-block blocks)))))
-
-(define (walk-block block)
- (state:reset!)
- (walk-rnode block))
-
-(define (walk-rnode rnode)
- (if (node-previous>1? rnode) (state:reset!)) ;Easy non-optimal solution.
- ((vector-method rnode walk-rnode) rnode))
-
-(define-vector-method rtl-snode-tag walk-rnode
- (lambda (rnode)
- (cse-statement (rnode-rtl rnode))
- (let ((next (snode-next rnode)))
- (if next (walk-rnode next)))))
-
-(define-vector-method rtl-pnode-tag walk-rnode
- (lambda (rnode)
- (cse-statement (rnode-rtl rnode))
- (let ((consequent (pnode-consequent rnode))
- (alternative (pnode-alternative rnode)))
- (if consequent
- (if alternative
- ;; Copy the world's state.
- (let ((state (state:get)))
- (walk-rnode consequent)
- (state:set! state)
- (walk-rnode alternative))
- (walk-rnode consequent))
- (if alternative
- (walk-rnode alternative))))))
-
-(define (cse-statement statement)
- ((cdr (or (assq (rtl:expression-type statement) cse-methods)
- (error "Missing CSE method" (car statement))))
- statement))
-
-(define cse-methods '())
-
-(define (define-cse-method type method)
- (let ((entry (assq type cse-methods)))
- (if entry
- (set-cdr! entry method)
- (set! cse-methods (cons (cons type method) cse-methods))))
- type)
-\f
-(define-cse-method 'ASSIGN
- (lambda (statement)
- (expression-replace! rtl:assign-expression rtl:set-assign-expression!
- statement
- (let ((address (rtl:assign-address statement)))
- (cond ((rtl:register? address)
- (lambda (volatile? insert-source!)
- (register-expression-invalidate! address)
- (if (not volatile?)
- (insert-register-destination! address (insert-source!)))))
- ((stack-reference? address)
- (lambda (volatile? insert-source!)
- (stack-reference-invalidate! address)
- (if (not volatile?)
- (insert-stack-destination! address (insert-source!)))))
- (else
- (lambda (volatile? insert-source!)
- (let ((memory-invalidate!
- (cond ((stack-push/pop? address)
- (lambda () 'DONE))
- ((heap-allocate? address)
- (lambda ()
- (register-expression-invalidate!
- (rtl:address-register address))))
- (else
- (memory-invalidator
- (expression-varies? address))))))
- (full-expression-hash address
- (lambda (hash volatile?* in-memory?*)
- (cond (volatile?* (memory-invalidate!))
- ((not volatile?)
- (let ((address
- (find-cheapest-expression address hash
- false)))
- (let ((element (insert-source!)))
- (memory-invalidate!)
- (insert-memory-destination!
- address
- element
- (modulo (+ (symbol-hash 'ASSIGN) hash)
- n-buckets)))))))))
- ;; **** Kludge. Works only because stack-pointer
- ;; gets used in very fixed way by code generator.
- (if (stack-push/pop? address)
- (stack-pointer-adjust!
- (rtl:address-number address))))))))))
-\f
-(define (noop statement) 'DONE)
-
-(define (trivial-action volatile? insert-source!)
- (if (not volatile?) (insert-source!)))
-
-(define ((normal-action thunk) volatile? insert-source!)
- (thunk)
- (if (not volatile?) (insert-source!)))
-
-(define (define-trivial-one-arg-method type get set)
- (define-cse-method type
- (lambda (statement)
- (expression-replace! get set statement trivial-action))))
-
-(define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2)
- (define-cse-method type
- (lambda (statement)
- (expression-replace! get-1 set-1 statement trivial-action)
- (expression-replace! get-2 set-2 statement trivial-action))))
-
-(define-trivial-two-arg-method 'EQ-TEST
- rtl:eq-test-expression-1 rtl:set-eq-test-expression-1!
- rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!)
-
-(define-trivial-one-arg-method 'TRUE-TEST
- rtl:true-test-expression rtl:set-true-test-expression!)
-
-(define-trivial-one-arg-method 'TYPE-TEST
- rtl:type-test-expression rtl:set-type-test-expression!)
-
-(define-trivial-one-arg-method 'UNASSIGNED-TEST
- rtl:type-test-expression rtl:set-unassigned-test-expression!)
-
-(define-cse-method 'RETURN noop)
-(define-cse-method 'PROCEDURE-HEAP-CHECK noop)
-(define-cse-method 'CONTINUATION-HEAP-CHECK noop)
-
-(define (define-stack-trasher type)
- (define-cse-method type trash-stack))
-
-(define (trash-stack statement)
- (stack-invalidate!)
- (stack-pointer-invalidate!))
-
-(define-stack-trasher 'SETUP-LEXPR)
-(define-stack-trasher 'MESSAGE-SENDER:VALUE)
-
-(define-cse-method 'INTERPRETER-CALL:ENCLOSE
- (lambda (statement)
- (let ((n (rtl:interpreter-call:enclose-size statement)))
- (stack-region-invalidate! 0 n)
- (stack-pointer-adjust! n))
- (expression-invalidate! (interpreter-register:enclose))))
-\f
-(define (define-lookup-method type get-environment set-environment! register)
- (define-cse-method type
- (lambda (statement)
- (expression-replace! get-environment set-environment! statement
- (normal-action
- (lambda ()
- (expression-invalidate! (register))
- (non-object-invalidate!)))))))
-
-(define-lookup-method 'INTERPRETER-CALL:ACCESS
- rtl:interpreter-call:access-environment
- rtl:set-interpreter-call:access-environment!
- interpreter-register:access)
-
-(define-lookup-method 'INTERPRETER-CALL:LOOKUP
- rtl:interpreter-call:lookup-environment
- rtl:set-interpreter-call:lookup-environment!
- interpreter-register:lookup)
-
-(define-lookup-method 'INTERPRETER-CALL:UNASSIGNED?
- rtl:interpreter-call:unassigned?-environment
- rtl:set-interpreter-call:unassigned?-environment!
- interpreter-register:unassigned?)
-
-(define-lookup-method 'INTERPRETER-CALL:UNBOUND?
- rtl:interpreter-call:unbound?-environment
- rtl:set-interpreter-call:unbound?-environment!
- interpreter-register:unbound?)
-
-(define (define-assignment-method type
- get-environment set-environment!
- get-value set-value!)
- (define-cse-method type
- (lambda (statement)
- (expression-replace! get-value set-value! statement trivial-action)
- (expression-replace! get-environment set-environment! statement
- (normal-action
- (lambda ()
- (memory-invalidate! true)
- (non-object-invalidate!)))))))
-
-(define-assignment-method 'INTERPRETER-CALL:DEFINE
- rtl:interpreter-call:define-environment
- rtl:set-interpreter-call:define-environment!
- rtl:interpreter-call:define-value
- rtl:set-interpreter-call:define-value!)
-
-(define-assignment-method 'INTERPRETER-CALL:SET!
- rtl:interpreter-call:set!-environment
- rtl:set-interpreter-call:set!-environment!
- rtl:interpreter-call:set!-value
- rtl:set-interpreter-call:set!-value!)
-\f
-(define (define-invocation-method type)
- (define-cse-method type
- noop
-#| This will be needed when the snode-next of an invocation
- gets connected to the callee's entry node.
- (lambda (statement)
- (let ((prefix (rtl:invocation-prefix statement)))
- (case (car prefix)
- ((NULL) (continuation-adjustment statement))
- ((MOVE-FRAME-UP)
- (let ((size (second prefix))
- (distance (third prefix)))
- (stack-region-invalidate! 0 (+ size distance)) ;laziness
- (stack-pointer-adjust! distance)))
- ((APPLY-STACK APPLY-CLOSURE) (trash-stack statement))
- (else (error "Bad prefix type" prefix)))))
-|#
- ))
-
-(define (continuation-adjustment statement)
- (let ((continuation (rtl:invocation-continuation statement)))
- (if continuation
- (stack-pointer-adjust! (+ (rtl:invocation-pushed statement)
- (continuation-delta continuation))))))
-
-(define-invocation-method 'INVOCATION:APPLY)
-(define-invocation-method 'INVOCATION:JUMP)
-(define-invocation-method 'INVOCATION:LEXPR)
-(define-invocation-method 'INVOCATION:PRIMITIVE)
-
-(define-cse-method 'INVOCATION:LOOKUP
- (lambda (statement)
- (continuation-adjustment statement)
- (expression-replace! rtl:invocation:lookup-environment
- rtl:set-invocation:lookup-environment!
- statement
- trivial-action)))
-
-(define (define-message-receiver type size)
- (define-cse-method type
- (let ((size (delay (- (size)))))
- (lambda (statement)
- (stack-pointer-adjust! (force size))))))
-
-(define-message-receiver 'MESSAGE-RECEIVER:CLOSURE
- rtl:message-receiver-size:closure)
-
-(define-message-receiver 'MESSAGE-RECEIVER:STACK
- rtl:message-receiver-size:closure)
-
-(define-message-receiver 'MESSAGE-RECEIVER:SUBPROBLEM
- rtl:message-receiver-size:subproblem)
-\f
-;;;; Canonicalization
-
-(define (expression-replace! statement-expression set-statement-expression!
- statement receiver)
- ;; Replace the expression by its cheapest equivalent. Returns two
- ;; values: (1) a flag which is true iff the expression is volatile;
- ;; and (2) a thunk which, when called, will insert the expression in
- ;; the hash table, returning the element. Do not call the thunk if
- ;; the expression is volatile.
- (let ((expression
- (expression-canonicalize (statement-expression statement))))
- (full-expression-hash expression
- (lambda (hash volatile? in-memory?)
- (let ((element
- (find-cheapest-valid-element expression hash volatile?)))
- (define (finish expression hash volatile? in-memory?)
- (set-statement-expression! statement expression)
- (receiver
- volatile?
- (expression-inserter expression element hash in-memory?)))
- (if element
- (let ((expression (element-expression element)))
- (full-expression-hash expression
- (lambda (hash volatile? in-memory?)
- (finish expression hash volatile? in-memory?))))
- (finish expression hash volatile? in-memory?)))))))
-
-(define ((expression-inserter expression element hash in-memory?))
- (or element
- (begin (if (rtl:register? expression)
- (set-register-expression! (rtl:register-number expression)
- expression)
- (mention-registers! expression))
- (let ((element* (hash-table-insert! hash expression false)))
- (set-element-in-memory?! element* in-memory?)
- (element-first-value element*)))))
-
-(define (expression-canonicalize expression)
- (cond ((rtl:register? expression)
- (or (register-expression
- (quantity-first-register
- (register-quantity (rtl:register-number expression))))
- expression))
- ((stack-reference? expression)
- (let ((register
- (quantity-first-register
- (stack-reference-quantity expression))))
- (or (and register (register-expression register))
- expression)))
- (else
- (rtl:map-subexpressions expression expression-canonicalize))))
-\f
-;;;; Invalidation
-
-(define (memory-invalidator variable?)
- (let ((predicate (if variable? element-address-varies? element-in-memory?)))
- (lambda ()
- (hash-table-delete-class! predicate))))
-
-(define (memory-invalidate! variable?)
- (hash-table-delete-class!
- (if variable? element-address-varies? element-in-memory?)))
-
-(define (non-object-invalidate!)
- (hash-table-delete-class!
- (lambda (element)
- (expression-not-object? (element-expression element)))))
-
-(define (element-address-varies? element)
- (expression-address-varies? (element-expression element)))
-
-(define (expression-invalidate! expression)
- ;; Delete any expression which refers to this expression from the
- ;; table.
- (if (rtl:register? expression)
- (register-expression-invalidate! expression)
- (hash-table-delete-class!
- (lambda (element)
- (expression-refers-to? (element-expression element) expression)))))
-
-(define (register-expression-invalidate! expression)
- ;; Invalidate a register expression. These expressions are handled
- ;; specially for efficiency -- the register is marked invalid but we
- ;; delay searching the hash table for relevant expressions.
- (register-invalidate! (rtl:register-number expression))
- (let ((hash (expression-hash expression)))
- (hash-table-delete! hash (hash-table-lookup hash expression))))
-
-(define (register-invalidate! register)
- (let ((next (register-next-equivalent register))
- (previous (register-previous-equivalent register))
- (quantity (register-quantity register)))
- (set-register-tick! register (1+ (register-tick register)))
- (if next
- (set-register-previous-equivalent! next previous)
- (set-quantity-last-register! quantity previous))
- (if previous
- (set-register-next-equivalent! previous next)
- (set-quantity-first-register! quantity next))
- (set-register-quantity! register (new-quantity register))
- (set-register-next-equivalent! register false)
- (set-register-previous-equivalent! register false)))
-\f
-;;;; Destination Insertion
-
-(define (insert-register-destination! expression element)
- ;; Insert EXPRESSION, which should be a register expression, into
- ;; the hash table as the destination of an assignment. ELEMENT is
- ;; the hash table element for the value being assigned to
- ;; EXPRESSION.
- (let ((class (element->class element))
- (register (rtl:register-number expression)))
- (define (register-equivalence! quantity)
- (set-register-quantity! register quantity)
- (let ((last (quantity-last-register quantity)))
- (if last
- (begin (set-register-next-equivalent! last register)
- (set-register-previous-equivalent! register last))
- (begin (set-quantity-first-register! quantity register)
- (set-quantity-last-register! quantity register))))
- (set-register-next-equivalent! register false)
- (set-quantity-last-register! quantity register))
-
- (set-register-expression! register expression)
- (if class
- (let ((expression (element-expression class)))
- (cond ((rtl:register? expression)
- (register-equivalence!
- (register-quantity (rtl:register-number expression))))
- ((stack-reference? expression)
- (register-equivalence!
- (stack-reference-quantity expression))))))
- (set-element-in-memory?!
- (hash-table-insert! (expression-hash expression) expression class)
- false)))
-
-(define (insert-stack-destination! expression element)
- (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
- expression
- (element->class element))
- false))
-
-(define (insert-memory-destination! expression element hash)
- (let ((class (element->class element)))
- (mention-registers! expression)
- (set-element-in-memory?! (hash-table-insert! hash expression class) true)))
-
-(define (mention-registers! expression)
- (if (rtl:register? expression)
- (let ((register (rtl:register-number expression)))
- (remove-invalid-references! register)
- (set-register-in-table! register (register-tick register)))
- (rtl:for-each-subexpression expression mention-registers!)))
-
-(define (remove-invalid-references! register)
- ;; If REGISTER is invalid, delete all expressions which refer to it
- ;; from the hash table.
- (if (let ((in-table (register-in-table register)))
- (and (not (negative? in-table))
- (not (= in-table (register-tick register)))))
- (let ((expression (register-expression register)))
- (hash-table-delete-class!
- (lambda (element)
- (let ((expression* (element-expression element)))
- (and (not (rtl:register? expression*))
- (expression-refers-to? expression* expression))))))))
-\f
-;;;; Table Search
-
-(define (find-cheapest-expression expression hash volatile?)
- ;; Find the cheapest equivalent expression for EXPRESSION.
- (let ((element (find-cheapest-valid-element expression hash volatile?)))
- (if element
- (element-expression element)
- expression)))
-
-(define (find-cheapest-valid-element expression hash volatile?)
- ;; Find the cheapest valid hash table element for EXPRESSION.
- ;; Returns false if no such element exists or if EXPRESSION is
- ;; VOLATILE?.
- (and (not volatile?)
- (let ((element (hash-table-lookup hash expression)))
- (and element
- (let ((element* (element-first-value element)))
- (if (eq? element element*)
- element
- (let loop ((element element*))
- (and element
- (let ((expression (element-expression element)))
- (if (or (rtl:register? expression)
- (expression-valid? expression))
- element
- (loop (element-next-value element))))))))))))
-
-(define (expression-valid? expression)
- ;; True iff all registers mentioned in EXPRESSION have valid values
- ;; in the hash table.
- (if (rtl:register? expression)
- (let ((register (rtl:register-number expression)))
- (= (register-in-table register) (register-tick register)))
- (rtl:all-subexpressions? expression expression-valid?)))
-
-(define (element->class element)
- ;; Return the cheapest element in the hash table which has the same
- ;; value as ELEMENT. This is necessary because ELEMENT may have
- ;; been deleted due to register or memory invalidation.
- (and element
- ;; If ELEMENT has been deleted from the hash table,
- ;; CLASS will be false. [ref crock-1]
- (let ((class (element-first-value element)))
- (or class
- (element->class (element-next-value element))))))
-\f
-;;;; Expression Hash
-
-(define (expression-hash expression)
- (full-expression-hash expression
- (lambda (hash do-not-record? hash-arg-in-memory?)
- hash)))
-
-(define (full-expression-hash expression receiver)
- (let ((do-not-record? false)
- (hash-arg-in-memory? false))
- (define (loop expression)
- (let ((type (rtl:expression-type expression)))
- (+ (symbol-hash type)
- (case type
- ((REGISTER)
- (quantity-number
- (register-quantity (rtl:register-number expression))))
- ((OFFSET)
- ;; Note that stack-references do not get treated as
- ;; memory for purposes of invalidation. This is because
- ;; (supposedly) no one ever accesses the stack directly
- ;; except the compiler's output, which is explicit.
- (let ((register (rtl:offset-register expression)))
- (if (interpreter-stack-pointer? register)
- (quantity-number (stack-reference-quantity expression))
- (begin (set! hash-arg-in-memory? true)
- (continue expression)))))
- ((PRE-INCREMENT POST-INCREMENT)
- (set! hash-arg-in-memory? true)
- (set! do-not-record? true)
- 0)
- (else (continue expression))))))
-
- (define (continue expression)
- (rtl:reduce-subparts expression + 0 loop hash-object))
-
- (let ((hash (loop expression)))
- (receiver (modulo hash n-buckets) do-not-record? hash-arg-in-memory?))))
-
-(define (hash-object object)
- (cond ((integer? object) object)
- ((symbol? object) (symbol-hash object))
- rtl:set-interpreter-call:set!-value!)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseep.scm,v 1.2 1987/03/20 05:12:44 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Common Subexpression Elimination: Expression Predicates
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define (expression-equivalent? x y validate?)
- ;; If VALIDATE? is true, assume that Y comes from the hash table and
- ;; should have its register references validated.
- (define (loop x y)
- (let ((type (rtl:expression-type x)))
- (and (eq? type (rtl:expression-type y))
- (case type
- ((REGISTER)
- (register-equivalent? x y))
- ((OFFSET)
- (let ((rx (rtl:offset-register x)))
- (and (register-equivalent? rx (rtl:offset-register y))
- (if (interpreter-stack-pointer? rx)
- (eq? (stack-reference-quantity x)
- (stack-reference-quantity y))
- (= (rtl:offset-number x)
- (rtl:offset-number y))))))
- (else
- (rtl:match-subexpressions x y loop))))))
-
- (define (register-equivalent? x y)
- (let ((x (rtl:register-number x))
- (y (rtl:register-number y)))
- (and (eq? (register-quantity x) (register-quantity y))
- (or (not validate?)
- (= (register-in-table y) (register-tick y))))))
-
- (loop x y))
-
-(define (expression-refers-to? x y)
- ;; True iff any subexpression of X matches Y.
- (define (loop x)
- (or (eq? x y)
- (if (eq? (rtl:expression-type x) (rtl:expression-type y))
- (expression-equivalent? x y false)
- (rtl:any-subexpression? x loop))))
- (loop x))
-\f
-(define (expression-address-varies? expression)
- (if (memq (rtl:expression-type expression)
- '(OFFSET PRE-INCREMENT POST-INCREMENT))
- (register-expression-varies? (rtl:address-register expression))
- (rtl:any-subexpression? expression expression-address-varies?)))
-
-(define (expression-varies? expression)
- ;; This procedure should not be called on a register expression.
- (let ((type (rtl:expression-type expression)))
- (or (memq type '(OFFSET PRE-INCREMENT POST-INCREMENT))
- (if (eq? type 'REGISTER)
- (register-expression-varies? expression)
- (rtl:any-subexpression? expression expression-varies?)))))
-
-(define (register-expression-varies? expression)
- (not (= regnum:regs-pointer (rtl:register-number expression))))
-
-(define (stack-push/pop? expression)
- (and (pre/post-increment? expression)
- (interpreter-stack-pointer? (rtl:address-register expression))))
-
-(define (heap-allocate? expression)
- (and (pre/post-increment? expression)
- (interpreter-free-pointer? (rtl:address-register expression))))
-
-(define-integrable (pre/post-increment? expression)
- (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT)))
-
-(define-integrable (expression-not-object? expression)
- (memq (rtl:expression-type expression)
- (loop x))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 1.1 1987/03/19 00:49:04 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Common Subexpression Elimination: Hash Table Abstraction
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define n-buckets 31)
-
-(define (make-hash-table)
- (make-vector n-buckets false))
-
-(define *hash-table*)
-
-(define-integrable (hash-table-ref hash)
- (vector-ref *hash-table* hash))
-
-(define-integrable (hash-table-set! hash element)
- (vector-set! *hash-table* hash element))
-
-(define element-tag (make-vector-tag false 'ELEMENT))
-(define element? (tagged-vector-predicate element-tag))
-
-(define-vector-slots element 1
- expression cost in-memory?
- next-hash previous-hash
- next-value previous-value first-value)
-
-(define (make-element expression)
- (vector element-tag expression false false false false false false false))
-\f
-(define (hash-table-lookup hash expression)
- (define (loop element)
- (and element
- (if (let ((expression* (element-expression element)))
- (or (eq? expression expression*)
- (expression-equivalent? expression expression* true)))
- element
- (loop (element-next-hash element)))))
- (loop (hash-table-ref hash)))
-
-(define (hash-table-insert! hash expression class)
- (let ((element (make-element expression))
- (cost (rtl:expression-cost expression)))
- (set-element-cost! element cost)
- (let ((next (hash-table-ref hash)))
- (set-element-next-hash! element next)
- (if next (set-element-previous-hash! next element)))
- (hash-table-set! hash element)
- (cond ((not class)
- (set-element-first-value! element element))
- ((< cost (element-cost class))
- (set-element-next-value! element class)
- (set-element-previous-value! class element)
- (let loop ((x element))
- (if x
- (begin (set-element-first-value! x element)
- (loop (element-next-value x))))))
- (else
- (set-element-first-value! element class)
- (let loop ((previous class)
- (next (element-next-value class)))
- (cond ((not next)
- (set-element-next-value! element false)
- (set-element-next-value! previous element)
- (set-element-previous-value! element previous))
- ((<= cost (element-cost next))
- (set-element-next-value! element next)
- (set-element-previous-value! next element)
- (set-element-next-value! previous element)
- (set-element-previous-value! element previous))
- (else
- (loop next (element-next-value next)))))))
- element))
-\f
-(define (hash-table-delete! hash element)
- (if element
- (begin
- ;; **** Mark this element as removed. [ref crock-1]
- (set-element-first-value! element false)
- (let ((next (element-next-value element))
- (previous (element-previous-value element)))
- (if next (set-element-previous-value! next previous))
- (if previous
- (set-element-next-value! previous next)
- (let loop ((element next))
- (if element
- (begin (set-element-first-value! element next)
- (loop (element-next-value element)))))))
- (let ((next (element-next-hash element))
- (previous (element-previous-hash element)))
- (if next (set-element-previous-hash! next previous))
- (if previous
- (set-element-next-hash! previous next)
- (hash-table-set! hash next))))))
-
-(define (hash-table-delete-class! predicate)
- (let table-loop ((i 0))
- (if (< i n-buckets)
- (let bucket-loop ((element (hash-table-ref i)))
- (if element
- (begin (if (predicate element)
- (hash-table-delete! i element))
- (bucket-loop (element-next-hash element)))
- (table-loop (1+ i)))))))
-\f
-(package (hash-table-copy)
-
-(define *elements*)
-
-(define-export (hash-table-copy table)
- (fluid-let ((*elements* '()))
- (vector-map table element-copy)))
-
-(define (element-copy element)
- (and element
- (let ((entry (assq element *elements*)))
- (if entry
- (cdr entry)
- (let ((new (make-element (element-expression element))))
- (set! *elements* (cons (cons element new) *elements*))
- (set-element-cost! new (element-cost element))
- (set-element-in-memory?! new (element-in-memory? element))
- (set-element-next-hash!
- new
- (element-copy (element-next-hash element)))
- (set-element-previous-hash!
- new
- (element-copy (element-previous-hash element)))
- (set-element-next-value!
- new
- (element-copy (element-next-value element)))
- (set-element-previous-value!
- new
- (element-copy (element-previous-value element)))
- (set-element-first-value!
- new
- (element-copy (element-first-value element)))
- new)))))
-
- (list->vector elements*))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.1 1987/03/19 00:49:07 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Common Subexpression Elimination: Register/Quantity Abstractions
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define quantity-tag (make-vector-tag false 'QUANTITY))
-(define quantity? (tagged-vector-predicate quantity-tag))
-(define-vector-slots quantity 1 number first-register last-register)
-
-(define *next-quantity-number*)
-
-(define (generate-quantity-number)
- (let ((n *next-quantity-number*))
- (set! *next-quantity-number* (1+ *next-quantity-number*))
- n))
-
-(define (make-quantity number first-register last-register)
- (vector quantity-tag number first-register last-register))
-
-(define (new-quantity register)
- (make-quantity (generate-quantity-number) register register))
-
-(define (quantity-copy quantity)
- (make-quantity (quantity-number quantity)
- (quantity-first-register quantity)
- (quantity-last-register quantity)))
-
-(define-register-references quantity)
-(define-register-references next-equivalent)
-(define-register-references previous-equivalent)
-(define-register-references expression)
-(define-register-references tick)
-(define-register-references in-table)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcsesr.scm,v 1.1 1987/03/19 00:49:12 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Common Subexpression Elimination: Stack References
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-(define *stack-offset*)
-(define *stack-reference-quantities*)
-
-(define (stack-reference? expression)
- (and (eq? (rtl:expression-type expression) 'OFFSET)
- (interpreter-stack-pointer? (rtl:address-register expression))))
-
-(define (stack-reference-quantity expression)
- (let ((n (+ *stack-offset* (rtl:offset-number expression))))
- (let ((entry (ass= n *stack-reference-quantities*)))
- (if entry
- (cdr entry)
- (let ((quantity (new-quantity false)))
- (set! *stack-reference-quantities*
- (cons (cons n quantity)
- *stack-reference-quantities*))
- quantity)))))
-
-(define-integrable (stack-pointer-adjust! offset)
- (set! *stack-offset* (+ (stack->memory-offset offset) *stack-offset*))
- (stack-pointer-invalidate!))
-
-(define-integrable (stack-pointer-invalidate!)
- (register-expression-invalidate! (interpreter-stack-pointer)))
-
-(define-integrable (stack-invalidate!)
- (set! *stack-reference-quantities* '()))
-
-(define (stack-region-invalidate! start end)
- (let ((end (+ *stack-offset* end)))
- (define (loop i quantities)
- (if (< i end)
- (loop (1+ i)
- (del-ass=! i quantities))
- (set! *stack-reference-quantities* quantities)))
- (loop (+ *stack-offset* start) *stack-reference-quantities*)))
-
-(define (stack-reference-invalidate! expression)
- (expression-invalidate! expression)
- (set! *stack-reference-quantities*
- (del-ass=! (+ *stack-offset* (rtl:offset-number expression))
- *stack-reference-quantities*)))
-
-(define ass= (association-procedure = car))
-(define del-ass=! (delete-association-procedure list-deletor! = car))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.55 1987/03/19 00:47:19 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; RTL Register Lifetime Analysis
-;;; Based on the GNU C Compiler
-
-(declare (usual-integrations))
-\f
-;;;; Lifetime Analysis
-
-(define (lifetime-analysis bblocks)
- (let ((changed? false))
- (define (loop first-pass?)
- (for-each (lambda (bblock)
- (let ((live-at-entry (bblock-live-at-entry bblock))
- (live-at-exit (bblock-live-at-exit bblock))
- (new-live-at-exit (bblock-new-live-at-exit bblock)))
- (if (or first-pass?
- (not (regset=? live-at-exit new-live-at-exit)))
- (begin (set! changed? true)
- (regset-copy! live-at-exit new-live-at-exit)
- (regset-copy! live-at-entry live-at-exit)
- (propagate-block bblock)
- (for-each-previous-node (bblock-entry bblock)
- (lambda (rnode)
- (regset-union! (bblock-new-live-at-exit
- (node-bblock rnode))
- live-at-entry)))))))
- bblocks)
- (if changed?
- (begin (set! changed? false)
- (loop false))
- (for-each (lambda (bblock)
- (regset-copy! (bblock-live-at-entry bblock)
- (bblock-live-at-exit bblock))
- (propagate-block&delete! bblock))
- bblocks)))
- (loop true)))
-
-(define (propagate-block bblock)
- (propagation-loop bblock
- (lambda (old dead live rtl rnode)
- (update-live-registers! old dead live rtl false))))
-
-(define (propagate-block&delete! bblock)
- (for-each-regset-member (bblock-live-at-entry bblock)
- (lambda (register)
- (set-register-bblock! register 'NON-LOCAL)))
- (propagation-loop bblock
- (lambda (old dead live rtl rnode)
- (if (rtl:invocation? rtl)
- (for-each-regset-member old register-crosses-call!))
- (if (instruction-dead? rtl old)
- (snode-delete! rnode)
- (begin (update-live-registers! old dead live rtl rnode)
- (for-each-regset-member old
- increment-register-live-length!))))))
-\f
-(define (propagation-loop bblock procedure)
- (let ((old (bblock-live-at-entry bblock))
- (dead (regset-allocate *n-registers*))
- (live (regset-allocate *n-registers*)))
- (bblock-walk-backward bblock
- (lambda (rnode previous)
- (regset-clear! dead)
- (regset-clear! live)
- (procedure old dead live (rnode-rtl rnode) rnode)))))
-
-(define (update-live-registers! old dead live rtl rnode)
- (mark-set-registers! old dead rtl rnode)
- (mark-used-registers! old live rtl rnode)
- (regset-difference! old dead)
- (regset-union! old live))
-
-(define (instruction-dead? rtl needed)
- (and (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (and (rtl:register? address)
- (let ((register (rtl:register-number address)))
- (and (pseudo-register? register)
- (not (regset-member? needed register))))))))
-\f
-(define (mark-set-registers! needed dead rtl rnode)
- ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
- ;; modes, since they are only used on the stack pointer.
- (if (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (if (interesting-register? address)
- (let ((register (rtl:register-number address)))
- (regset-adjoin! dead register)
- (if rnode
- (let ((rnode* (register-next-use register)))
- (record-register-reference register rnode)
- (if (and (regset-member? needed register)
- rnode*
- (eq? (node-bblock rnode) (node-bblock rnode*)))
- (set-rnode-logical-link! rnode* rnode)))))))))
-
-(define (mark-used-registers! needed live rtl rnode)
- (define (loop expression)
- (if (interesting-register? expression)
- (let ((register (rtl:register-number expression)))
- (regset-adjoin! live register)
- (if rnode
- (begin (record-register-reference register rnode)
- (set-register-next-use! register rnode)
- (if (and (not (regset-member? needed register))
- (not (rnode-dead-register? rnode register)))
- (begin (set-rnode-dead-registers!
- rnode
- (cons register
- (rnode-dead-registers rnode)))
- (increment-register-n-deaths! register))))))
- (rtl:for-each-subexpression expression loop)))
- (if (and (rtl:assign? rtl)
- (rtl:register? (rtl:assign-address rtl)))
- (if (let ((register (rtl:register-number (rtl:assign-address rtl))))
- (or (machine-register? register)
- (regset-member? needed register)))
- (loop (rtl:assign-expression rtl)))
- (rtl:for-each-subexpression rtl loop)))
-
-(define (record-register-reference register rnode)
- (let ((bblock (node-bblock rnode))
- (bblock* (register-bblock register)))
- (cond ((not bblock*)
- (set-register-bblock! register bblock))
- ((not (eq? bblock bblock*))
- (set-register-bblock! register 'NON-LOCAL)))
- (increment-register-n-refs! register)))
-
-(define (interesting-register? expression)
- (and (rtl:register? expression)
- (pseudo-register? (rtl:register-number expression))))
-\f
-;;;; Dead Code Elimination
-
-(define (dead-code-elimination bblocks)
- (for-each (lambda (bblock)
- (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
- (let ((live (regset-copy (bblock-live-at-entry bblock)))
- (births (make-regset *n-registers*)))
- (bblock-walk-forward bblock
- (lambda (rnode next)
- (if next
- (begin (optimize-rtl live rnode next)
- (regset-clear! births)
- (mark-set-registers! live
- births
- (rnode-rtl rnode)
- false)
- (for-each (lambda (register)
- (regset-delete! live register))
- (rnode-dead-registers rnode))
- (regset-union! live births))))))))
- bblocks))
-
-(define (optimize-rtl live rnode next)
- (let ((rtl (rnode-rtl rnode)))
- (if (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (if (rtl:register? address)
- (let ((register (rtl:register-number address)))
- (if (and (pseudo-register? register)
- (= 2 (register-n-refs register))
- (rnode-dead-register? next register)
- (rtl:any-subexpression? (rnode-rtl next)
- (lambda (expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression)
- register)))))
- (begin
- (let ((dead (rnode-dead-registers rnode)))
- (for-each increment-register-live-length! dead)
- (set-rnode-dead-registers!
- next
- (eqv-set-union dead
- (delv! register
- (rnode-dead-registers next)))))
- (for-each-regset-member live
- decrement-register-live-length!)
- (rtl:modify-subexpressions (rnode-rtl next)
- (lambda (expression set-expression!)
- (if (and (rtl:register? expression)
- (= (rtl:register-number expression)
- register))
- (set-expression! (rtl:assign-expression rtl)))))
- (snode-delete! rnode)
- (reset-register-n-refs! register)
- (reset-register-n-deaths! register)
- (reset-register-live-length! register)
- (set-register-next-use! register false)
- (set-register-bblock! register false)))))))))
-\f
-;;;; Debugging Output
-
-(define (dump-register-info)
- (for-each-pseudo-register
- (lambda (register)
- (if (positive? (register-n-refs register))
- (begin (newline)
- (write register)
- (write-string ": renumber ")
- (write (register-renumber register))
- (write-string "; nrefs ")
- (write (register-n-refs register))
- (write-string "; length ")
- (write (register-live-length register))
- (write-string "; ndeaths ")
- (write (register-n-deaths register))
- (let ((bblock (register-bblock register)))
- (cond ((eq? bblock 'NON-LOCAL)
- (if (register-crosses-call? register)
- (write-string "; crosses calls")
- (write-string "; multiple blocks")))
- (bblock
- (write-string "; block ")
- (write (unhash bblock)))
- (else
- (write-string "; no block!")))))))))
-
-(define (dump-block-info bblocks)
- (let ((null-set (make-regset *n-registers*))
- (machine-regs (make-regset *n-registers*)))
- (for-each-machine-register
- (lambda (register)
- (regset-adjoin! machine-regs register)))
- (for-each (lambda (bblock)
- (newline)
- (newline)
- (write bblock)
- (let ((exit (bblock-exit bblock)))
- (let loop ((rnode (bblock-entry bblock)))
- (pp (rnode-rtl rnode))
- (if (not (eq? rnode exit))
- (loop (snode-next rnode)))))
- (let ((live-at-exit (bblock-live-at-exit bblock)))
- (regset-difference! live-at-exit machine-regs)
- (if (not (regset=? null-set live-at-exit))
- (begin (newline)
- (write-string "Registers live at end:")
- (for-each-regset-member live-at-exit
- (lambda (register)
- (write-string " ")
- (write register)))))))
- (pseudo-register? (rtl:register-number expression))))
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.c,v 9.21 1987/01/22 14:14:32 jinx Rel $ */
-
-/* CONTAINS: */
-/* Scheme_Array constructors, and selectors */
-/* Also procedures for converting between C_Array, and Scheme_Vector */
-
-/* See array.h for definition using NM_VECTOR, */
-/* and for many useful EXTERN */
-/* ARRAY = SEQUENCE OF REALS */
-\f
-#include "scheme.h"
-#include "primitive.h"
-#include "flonum.h"
-#include "array.h"
-#include <math.h>
-
-/* first a useful procedure */
-
-int Scheme_Number_To_REAL(Arg, Cell) Pointer Arg; REAL *Cell;
-/* 0 means conversion ok, 1 means too big, 2 means not a number */
-{ long Value;
- switch (Type_Code(Arg)) {
- case TC_FIXNUM:
- if (Get_Integer(Arg) == 0)
- *Cell = 0.0;
- else
- { long Value;
- Sign_Extend(Arg, Value);
- *Cell = ((REAL) Value);
- }
- break;
- case TC_BIG_FLONUM:
- *Cell = ((REAL) Get_Float(Arg));
- break;
- case TC_BIG_FIXNUM:
- { Pointer Result = Big_To_Float(Arg);
- if (Type_Code(Result) == TC_BIG_FLONUM)
- *Cell = ((REAL) Get_Float(Result));
- else return (1);
- }
- break;
- default: return (2);
- break;
- }
- return (0);
-}
-\f
-int Scheme_Number_To_Double(Arg, Cell) Pointer Arg; double *Cell;
-/* 0 means conversion ok, 1 means too big, 2 means not a number */
-{ long Value;
- switch (Type_Code(Arg)) {
- case TC_FIXNUM:
- if (Get_Integer(Arg) == 0)
- *Cell = 0.0;
- else
- { long Value;
- Sign_Extend(Arg, Value);
- *Cell = ((double) Value);
- }
- break;
- case TC_BIG_FLONUM:
- *Cell = ((double) Get_Float(Arg));
- break;
- case TC_BIG_FIXNUM:
- { Pointer Result = Big_To_Float(Arg);
- if (Type_Code(Result) == TC_BIG_FLONUM)
- *Cell = ((double) Get_Float(Result));
- else return (1);
- }
- break;
- default: return (2);
- break;
- }
- return (0);
-}
-\f
-void C_Array_Copy(From_Array, To_Array, Length) REAL *From_Array, *To_Array; long Length;
-{ long i;
- REAL *To_Here, *From_Here;
- To_Here = To_Array;
- From_Here = From_Array;
- for (i=0; i < Length; i++) {
- *To_Here++ = ((REAL) *From_Here++) ;
- }
-}
-
-\f
-/**** Scheme Primitives *****/
-
-/* I think this is not needed, can be done at s-code ...
-Define_Primitive(Prim_Array_Predicate, 1, "ARRAY?")
-{ Primitive_1_Args();
- if (Type_Code(Arg1)==TC_ARRAY) return TRUE;
- else return NIL;
-}
-*/
-\f
-Define_Primitive(Prim_Vector_To_Array, 1, "VECTOR->ARRAY")
-{ Pointer Scheme_Vector_To_Scheme_Array();
- Primitive_1_Args();
- Arg_1_Type(TC_VECTOR);
- return Scheme_Vector_To_Scheme_Array(Arg1);
-}
-\f
-Define_Primitive(Prim_Array_To_Vector, 1, "ARRAY->VECTOR")
-{ Pointer Scheme_Array_To_Scheme_Vector();
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- return Scheme_Array_To_Scheme_Vector(Arg1);
-}
-\f
-Define_Primitive(Prim_Array_Cons, 2, "ARRAY-CONS")
-{ long Length, i, allocated_cells;
- REAL Init_Value, *Next;
- int Error_Number;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_FIXNUM);
- Range_Check(Length, Arg1, 0, ARRAY_MAX_LENGTH, ERR_ARG_1_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_REAL(Arg2, &Init_Value);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
-
- Allocate_Array(Result,Length,allocated_cells);
- Next = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- *Next++ = Init_Value;
- }
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Length, 1, "ARRAY-LENGTH")
-{ Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- return Make_Pointer(TC_FIXNUM, Array_Length(Arg1));
-}
-\f
-Define_Primitive(Prim_Array_Ref, 2, "ARRAY-REF")
-{ long Index;
- REAL *Array, value;
- Pointer *Result;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Array = Scheme_Array_To_C_Array(Arg1);
- value = Array[Index];
- Reduced_Flonum_Result((double) value);
-}
-\f
-Define_Primitive(Prim_Array_Set, 3, "ARRAY-SET!")
-{ long Index;
- REAL *Array, Old_Value;
- int Error_Number;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Index, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Array = Scheme_Array_To_C_Array(Arg1);
- Old_Value = Array[Index];
-
- Error_Number = Scheme_Number_To_REAL(Arg3, &Array[Index]);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Reduced_Flonum_Result((double) Old_Value);
-}
-\f
-Define_Primitive(Prim_Array_Copy, 1, "ARRAY-COPY")
-{ long Length, i, allocated_cells;
- REAL *To_Array, *From_Array;
- Pointer Result;
-
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
-
- Allocate_Array(Result, Length, allocated_cells);
- From_Array = Scheme_Array_To_C_Array(Arg1);
- To_Array = Scheme_Array_To_C_Array(Result);
-
- C_Array_Copy(From_Array, To_Array, Length);
- return Result;
-}
-\f
-Define_Primitive(Prim_SubArray, 3, "SUBARRAY")
-{ long Length, i, allocated_cells, Start, End, New_Length;
- REAL *To_Here, *From_Here;
- Pointer Result;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Arg_3_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE);
- if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- New_Length = (End - Start) + 1;
- Allocate_Array(Result, New_Length, allocated_cells);
- From_Here = Nth_Array_Loc(Arg1, Start);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- C_Array_Copy(From_Here, To_Here, New_Length);
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Set_SubArray, 4, "ARRAY-SET-SUBARRAY!")
-{ long Length, i, Start, End, New_Length;
- REAL *To_Here, *From_Here;
- Pointer Result;
-
- Primitive_4_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Arg_3_Type(TC_FIXNUM);
- Arg_4_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Range_Check(Start, Arg2, 0, Array_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Range_Check(End, Arg3, 0, Array_Length(Arg1)-1, ERR_ARG_3_BAD_RANGE);
- if (Start>End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- New_Length = (End - Start) + 1;
- if (New_Length!=Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
- From_Here = Scheme_Array_To_C_Array(Arg4);
- To_Here = Nth_Array_Loc(Arg1, Start);
-
- C_Array_Copy(From_Here, To_Here, New_Length);
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Array_Append, 2, "ARRAY-APPEND")
-{ long Length, Length1, Length2, i, allocated_cells;
- REAL *To_Here, *From_Here;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length1 = Array_Length(Arg1);
- Length2 = Array_Length(Arg2);
- Length = Length1 + Length2;
-
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
- From_Here = Scheme_Array_To_C_Array(Arg1);
-
- for (i=0; i < Length1; i++) {
- *To_Here++ = *From_Here;
- From_Here++ ;
- }
-
- From_Here = Scheme_Array_To_C_Array(Arg2);
- for (i=0; i < Length2; i++) {
- *To_Here++ = *From_Here;
- From_Here++ ;
- }
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Reverse, 1, "ARRAY-REVERSE!")
-{ long Length, i,j, Half_Length;
- REAL *Array, Temp;
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Half_Length = Length/2;
- Array = Scheme_Array_To_C_Array(Arg1);
-
- for (i=0, j=Length-1; i<Half_Length; i++, j--) {
- Temp = Array[j];
- Array[j] = Array[i];
- Array[i] = Temp;
- }
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Array_Scale, 2, "ARRAY-SCALE!")
-{ long Length, i;
- REAL *To_Here, *From_Here, Scale;
- Pointer Result;
- int Error_Number;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- Error_Number = Scheme_Number_To_REAL(Arg2, &Scale);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
-
- Result = Arg1;
- From_Here = Scheme_Array_To_C_Array(Arg1);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- *To_Here++ = (Scale * (*From_Here));
- From_Here++ ;
- }
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Log, 1, "ARRAY-LOG!")
-{ long Length, i, allocated_cells;
- REAL *To_Here, *From_Here;
- Pointer Result;
-
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
-
- Result = Arg1;
- From_Here = Scheme_Array_To_C_Array(Arg1);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- REAL Value= (*From_Here);
- if (Value<0.0) Primitive_Error(ERR_ARG_1_BAD_RANGE); /* log of negative ? */
- *To_Here++ = ((REAL) log((double) Value));
- From_Here++ ;
- }
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Min_Max, 1, "ARRAY-MIN-MAX")
-{ long Length, nmin, nmax;
- Pointer Result, *Orig_Free;
- REAL *Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Array= Scheme_Array_To_C_Array(Arg1);
- Length = Array_Length(Arg1);
- C_Array_Find_Min_Max(Array, Length, &nmin, &nmax);
- Primitive_GC_If_Needed(4);
- Result = Make_Pointer(TC_LIST, Free);
- Orig_Free = Free;
- Free+=4;
- My_Store_Reduced_Flonum_Result(Array[nmin], *Orig_Free);
- Orig_Free+=1;
- *Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
- My_Store_Reduced_Flonum_Result(Array[nmax], *Orig_Free);
- *(++Orig_Free)=NIL;
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Min_Max_Index, 1, "ARRAY-MIN-MAX-INDEX")
-{ long Length, nmin, nmax;
- Pointer Result, *Orig_Free;
- REAL *Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Array= Scheme_Array_To_C_Array(Arg1);
- Length = Array_Length(Arg1);
- C_Array_Find_Min_Max(Array, Length, &nmin, &nmax);
- Primitive_GC_If_Needed(4);
- Result = Make_Pointer(TC_LIST, Free);
- Orig_Free = Free;
- Free+=4;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmin);
- *Orig_Free++ = Make_Pointer(TC_LIST, Orig_Free+1);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nmax);
- *Orig_Free=NIL;
- return Result;
-}
-\f
-void C_Array_Find_Min_Max(x, n, nmin, nmax) REAL *x; long n, *nmax, *nmin;
-{ REAL *xold = x;
- register REAL xmin, xmax;
- register long nnmin, nnmax;
- register long count;
-
- nnmin = nnmax = 0;
- xmin = xmax = *x++;
- n--;
- count = 1;
- if(n>0)
- {
- do {
- if(*x < xmin) {
- nnmin = count++ ;
- xmin = *x++ ;
- } else if(*x > xmax) {
- nnmax = count++ ;
- xmax = *x++ ;
- } else {
- count++ ;
- x++ ;
- }
- } while( --n > 0 ) ;
- }
- *nmin = nnmin ;
- *nmax = nnmax ;
-}
-\f
-Define_Primitive(Prim_Array_Find_Average, 1, "ARRAY-AVERAGE")
-{ long Length; REAL average;
- Primitive_1_Args();
- Arg_1_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
-
- C_Array_Find_Average( Scheme_Array_To_C_Array(Arg1), Length, &average);
- Reduced_Flonum_Result((double) average);
-}
-\f
-void C_Array_Find_Average(Array, Length, pAverage)
- long Length; REAL *Array, *pAverage;
-{ long i;
- long array_index;
- REAL average_n, sum;
-
- average_n = 0.0;
- array_index = 0;
- while (array_index<Length) {
- sum = 0.0;
- for (i=0;((array_index<Length) && (i<2000));i++) {
- sum += Array[array_index];
- array_index++;
- }
- average_n += (sum / ((REAL) Length));
- }
- *pAverage = average_n;
-}
-\f
-Define_Primitive(Prim_Array_Make_Histogram, 2, "ARRAY-MAKE-HISTOGRAM")
-{ long Length, npoints, allocated_cells;
- REAL *Array, *Histogram;
- Pointer Result;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Range_Check(npoints, Arg2, 1, (2*Length), ERR_ARG_2_BAD_RANGE);
-
- Allocate_Array(Result, npoints, allocated_cells);
- Array = Scheme_Array_To_C_Array(Arg1);
- Histogram = Scheme_Array_To_C_Array(Result);
- C_Array_Make_Histogram(Array, Length, Histogram, npoints);
- return Result;
-}
-\f
-void C_Array_Make_Histogram(Array, Length, Histogram, npoints)
- REAL Array[], Histogram[]; long Length, npoints;
-{ REAL Max,Min, Offset, Scale;
- long i, nmin,nmax, index;
- C_Array_Find_Min_Max(Array, Length, &nmin,&nmax);
- Min=Array[nmin]; Max=Array[nmax];
- Find_Offset_Scale_For_Linear_Map(Min,Max, 0.0, ((REAL) (npoints-1)), &Offset, &Scale);
- for (i=0;i<npoints;i++) {
- Histogram[i] = 0.0; }
- for (i=0;i<Length;i++) {
- index = (long) (floor((double) ((Scale*Array[i]) + Offset)));
- Histogram[index] += 1.0; }
-}
-
-\f
-Define_Primitive(Prim_Array_Clip_Min_Max, 3, "ARRAY-CLIP-MIN-MAX!")
-{ long Length, i; /* , allocated_cells; */
- REAL *To_Here, *From_Here, xmin, xmax;
- Pointer Result;
- int Error_Number;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Error_Number=Scheme_Number_To_REAL(Arg2, &xmin);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Error_Number=Scheme_Number_To_REAL(Arg3, &xmax);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Length = Array_Length(Arg1);
- Result = Arg1;
- From_Here = Scheme_Array_To_C_Array(Arg1);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- if (xmin>xmax) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- for (i=0; i < Length; i++) {
- if ((*From_Here)<xmin) *To_Here++ = xmin;
- else if ((*From_Here)>xmax) *To_Here++ = xmax;
- else *To_Here++ = *From_Here;
- From_Here++ ;
- }
- return Result;
-}
-\f
-void C_Array_Clip(Length, From_Here, To_Here, Min_Val, Max_Val)
- long Length; REAL *From_Here, *To_Here, Min_Val, Max_Val;
-{ long i;
- for (i=0; i < Length; i++) {
- if ((*From_Here)<Min_Val) *To_Here++ = Min_Val;
- else if ((*From_Here)>Max_Val) *To_Here++ = Max_Val;
- else *To_Here++ = *From_Here;
- From_Here++ ;
- }
-}
-
-\f
-Define_Primitive(Prim_Array_Make_Polar, 2, "ARRAY-MAKE-POLAR!")
-{ long Length, i;
- REAL *To_Here_Mag, *To_Here_Phase;
- REAL *From_Here_Real, *From_Here_Imag;
- Pointer Result_Mag, Result_Phase, answer;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- Result_Mag = Arg1;
- Result_Phase = Arg2;
-
- From_Here_Real = Scheme_Array_To_C_Array(Arg1);
- From_Here_Imag = Scheme_Array_To_C_Array(Arg2);
- To_Here_Mag = Scheme_Array_To_C_Array(Result_Mag);
- To_Here_Phase = Scheme_Array_To_C_Array(Result_Phase);
-
- for (i=0; i < Length; i++) {
- C_Make_Polar(*From_Here_Real, *From_Here_Imag, *To_Here_Mag, *To_Here_Phase);
- From_Here_Real++ ;
- From_Here_Imag++ ;
- To_Here_Mag++ ;
- To_Here_Phase++ ;
- }
-
- Primitive_GC_If_Needed(4);
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Result_Mag;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Result_Phase;
- *Free++ = NIL;
- return answer;
-}
-\f
-Define_Primitive(Prim_Array_Find_Magnitude, 2, "ARRAY-FIND-MAGNITUDE")
-{ long Length, i, allocated_cells;
- REAL *From_Here_Real, *From_Here_Imag, *To_Here;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
- From_Here_Real = Scheme_Array_To_C_Array(Arg1);
- From_Here_Imag = Scheme_Array_To_C_Array(Arg2);
- for (i=0; i<Length; i++) {
- C_Find_Magnitude(*From_Here_Real, *From_Here_Imag, *To_Here);
- From_Here_Real++ ;
- From_Here_Imag++ ;
- To_Here++ ;
- }
- return Result;
-}
-
-\f
-/* ATTENTION: To1,To2 SHOULD BE Length1-1, and Length2-2 RESPECTIVELY ! */
-
-#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
-{ long Min_of_N_To1=min((N),(To1)); \
- long mi, N_minus_mi; \
- REAL Sum=0.0; \
- for (mi=max(0,(N)-(To2)), N_minus_mi=(N)-mi; mi <= Min_of_N_To1; mi++, N_minus_mi--) \
- Sum += (X[mi] * Y[N_minus_mi]); \
- (Result)=Sum; \
-}
-\f
-Define_Primitive(Prim_Convolution_Point, 3, "CONVOLUTION-POINT")
-{ long Length1, Length2, N;
- REAL *Array1, *Array2;
- REAL C_Result;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Arg_3_Type(TC_FIXNUM);
- Length1 = Array_Length(Arg1);
- Length2 = Array_Length(Arg2);
- N = Get_Integer(Arg3);
- Array1 = Scheme_Array_To_C_Array(Arg1);
- Array2 = Scheme_Array_To_C_Array(Arg2);
- C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
- Reduced_Flonum_Result(C_Result);
-}
-\f
-Define_Primitive(Prim_Array_Convolution, 2, "ARRAY-CONVOLUTION")
-{ long Endpoint1, Endpoint2, allocated_cells, i;
- /* ASSUME A SIGNAL FROM INDEX 0 TO ENDPOINT=LENGTH-1 */
- long Resulting_Length;
- REAL *Array1, *Array2, *To_Here;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Endpoint1 = Array_Length(Arg1) - 1;
- Endpoint2 = Array_Length(Arg2) - 1;
- Resulting_Length = Endpoint1 + Endpoint2 + 1;
- Array1 = Scheme_Array_To_C_Array(Arg1);
- Array2 = Scheme_Array_To_C_Array(Arg2);
-
- allocated_cells = (Resulting_Length * REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
- Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = Resulting_Length;
- Free += allocated_cells;
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Resulting_Length; i++) {
- C_Convolution_Point_Macro(Array1, Array2, Endpoint1, Endpoint2, i, *To_Here);
- To_Here++;
- }
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Multiplication_Into_Second_One, 2, "ARRAY-MULTIPLICATION-INTO-SECOND-ONE!")
-{ long Length, i;
- REAL *To_Here;
- REAL *From_Here_1, *From_Here_2;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Result = Arg2;
-
- From_Here_1 = Scheme_Array_To_C_Array(Arg1);
- From_Here_2 = Scheme_Array_To_C_Array(Arg2);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- *To_Here++ = (*From_Here_1) * (*From_Here_2);
- From_Here_1++ ;
- From_Here_2++ ;
- }
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Complex_Multiplication_Into_Second_One, 4, "ARRAY-COMPLEX-MULTIPLICATION-INTO-SECOND-ONE!")
-{ long Length, i;
- REAL *To_Here_1, *To_Here_2;
- REAL *From_Here_1, *From_Here_2, *From_Here_3, *From_Here_4;
- REAL Temp;
- Pointer Result_1, Result_2;
-
- Primitive_4_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Arg_3_Type(TC_ARRAY);
- Arg_4_Type(TC_ARRAY);
- Length = Array_Length(Arg1);
- if (Length != Array_Length(Arg2)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Length != Array_Length(Arg3)) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Length != Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
-
- Result_1 = Arg3;
- Result_2 = Arg4;
-
- From_Here_1 = Scheme_Array_To_C_Array(Arg1);
- From_Here_2 = Scheme_Array_To_C_Array(Arg2);
- From_Here_3 = Scheme_Array_To_C_Array(Arg3);
- From_Here_4 = Scheme_Array_To_C_Array(Arg4);
- To_Here_1 = Scheme_Array_To_C_Array(Result_1);
- To_Here_2 = Scheme_Array_To_C_Array(Result_2);
-
- for (i=0; i < Length; i++) {
- Temp = (*From_Here_1) * (*From_Here_3) - (*From_Here_2) * (*From_Here_4);
- *To_Here_2++ = (*From_Here_1) * (*From_Here_4) + (*From_Here_2) * (*From_Here_3);
- *To_Here_1++ = Temp;
- From_Here_1++ ;
- From_Here_2++ ;
- From_Here_3++ ;
- From_Here_4++ ;
- }
- return NIL;
-}
-\f
-Define_Primitive(Prim_Array_Linear_Superposition_Into_Second_One, 4, "ARRAY-LINEAR-SUPERPOSITION-INTO-SECOND-ONE!")
-{ long Length, i;
- REAL *To_Here, Coeff1, Coeff2;
- REAL *From_Here_1, *From_Here_2;
- Pointer Result;
- int Error_Number;
-
- Primitive_4_Args();
- Error_Number = Scheme_Number_To_REAL(Arg1, &Coeff1);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Arg_2_Type(TC_ARRAY);
- Error_Number = Scheme_Number_To_REAL(Arg3, &Coeff2);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- Arg_4_Type(TC_ARRAY);
-
- Length = Array_Length(Arg2);
- if (Length != Array_Length(Arg4)) Primitive_Error(ERR_ARG_4_BAD_RANGE);
-
- Result = Arg4;
-
- From_Here_1 = Scheme_Array_To_C_Array(Arg2);
- From_Here_2 = Scheme_Array_To_C_Array(Arg4);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i < Length; i++) {
- *To_Here++ = (Coeff1 * (*From_Here_1)) + (Coeff2 * (*From_Here_2));
- From_Here_1++ ;
- From_Here_2++ ;
- }
- return Result;
-}
-\f
-/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
-
-Define_Primitive(Prim_Sample_Periodic_Function, 4, "SAMPLE-PERIODIC-FUNCTION")
-{ long N, i, allocated_cells, Function_Number;
- double Signal_Frequency, Sampling_Frequency, DT, DTi;
- double twopi = 6.28318530717958;
- Pointer Result, Pfunction_number, Psignal_frequency;
- Pointer Pfunction_Number;
- int Error_Number;
- REAL *To_Here;
- double unit_square_wave(), unit_triangle_wave();
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); /* fix this */
-
- Error_Number = Scheme_Number_To_Double(Arg2, &Signal_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_Double(Arg3, &Sampling_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
-
- Allocate_Array(Result, N, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- DT = (double) (twopi * Signal_Frequency * (1 / Sampling_Frequency));
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) cos(DTi);
- else if (Function_Number == 1)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) sin(DTi);
- else if (Function_Number == 2)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) unit_square_wave(DTi);
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) unit_triangle_wave(DTi);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
-}
-\f
-double hamming(t, length) double t, length;
-{ double twopi = 6.28318530717958;
- double pi = twopi/2.;
- double t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
- else return (0);
-}
-\f
-double hanning(t, length) double t, length;
-{ double twopi = 6.28318530717958;
- double pi = twopi/2.;
- double t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0)) return(.5 * (1 - t_bar));
- else return (0);
-}
-\f
-double unit_square_wave(t) double t;
-{ double twopi = 6.28318530717958;
- double fmod(), fabs();
- double pi = twopi/2.;
- double t_bar = ((REAL) fabs(fmod( ((double) t), twopi)));
- if (t_bar < pi) return(1);
- else return(-1);
-}
-\f
-double unit_triangle_wave(t) double t;
-{ double twopi = 6.28318530717958;
- double pi = twopi/2.;
- double pi_half = pi/2.;
- double three_pi_half = pi+pi_half;
- double t_bar = ((double) fabs(fmod( ((double) t), twopi)));
-
- if (t_bar<pi_half) return(-(t_bar/pi));
- else if (t_bar<pi) return(t_bar/pi);
- else if (t_bar<three_pi_half) return((twopi-t_bar)/pi);
- else return (-((twopi-t_bar)/pi));
-}
-\f
-Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION")
-{ long N, i, allocated_cells, Function_Number;
- double Sampling_Frequency, DT, DTi;
- double twopi = 6.28318530717958;
- Pointer Result;
- int Error_Number;
- REAL *To_Here, twopi_dt;
-
- Primitive_3_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_3_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 6, ERR_ARG_1_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_Double(Arg2, &Sampling_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE);
-
- Allocate_Array(Result, N, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- DT = (twopi * (1 / Sampling_Frequency));
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) rand();
- else if (Function_Number == 1)
- { double length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) hanning(DTi, length);
- }
- else if (Function_Number == 2)
- { double length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) hamming(DTi, length);
- }
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) sqrt(DTi);
- else if (Function_Number == 4)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) log(DTi);
- else if (Function_Number == 5)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = (REAL) exp(DTi);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE")
-{ long Length, Pseudo_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
-
- Sign_Extend(Arg2, Sampling_Ratio); /* Sampling_Ratio = integer ratio of sampling_frequencies */
- Sampling_Ratio = Sampling_Ratio % Length; /* periodicity */
- if (Sampling_Ratio < 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- Pseudo_Length = Length * Sampling_Ratio;
- for (i=0; i<Pseudo_Length; i += Sampling_Ratio) { /* new Array has the same Length by assuming periodicity */
- array_index = i % Length;
- *To_Here++ = Array[array_index];
- }
-
- return Result;
-}
-\f
-/* DONE WITHOUT SIDE-EFFECTS FOR SIMPLICITY */
-Define_Primitive(Prim_Array_Periodic_Shift, 2, "ARRAY-PERIODIC-SHIFT")
-{ long Length, Shift;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Sign_Extend(Arg2, Shift);
- Shift = Shift % Length; /* periodic waveform, same sign as dividend */
- Array = Scheme_Array_To_C_Array(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Length; i++) { /* new Array has the same Length by assuming periodicity */
- array_index = (i+Shift) % Length;
- if (array_index<0) array_index = Length + array_index; /* wrap around */
- *To_Here++ = Array[array_index];
- }
-
- return Result;
-}
-\f
-/* this should really be done in SCHEME using ARRAY-MAP ! */
-
-Define_Primitive(Prim_Array_Aperiodic_Downsample, 2, "ARRAY-APERIODIC-DOWNSAMPLE")
-{ long Length, New_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Range_Check(Sampling_Ratio, Arg2, 1, Length, ERR_ARG_2_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Arg1);
- New_Length = Length / Sampling_Ratio; /* greater than zero */
- Allocate_Array(Result, New_Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Length; i += Sampling_Ratio) {
- *To_Here++ = Array[i];
- }
-
- return Result;
-}
-\f
-/* ARRAY-APERIODIC-SHIFT can be done in scheme using subarray, and array-append */
-
-/* for UPSAMPLING
- if ((Length % Sampling_Ratio) != 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- UNIMPLEMENTED YET !!!
- */
-
-/* END ARRAY PROCESSING */
-
-
-\f
-/*********** CONVERSION BETWEEN ARRAYS,VECTORS ********************/
-
-Pointer Scheme_Array_To_Scheme_Vector(Scheme_Array) Pointer Scheme_Array;
-{ REAL *Array;
- long Length;
- Pointer C_Array_To_Scheme_Vector();
-
- Length = Array_Length(Scheme_Array);
- Array = Scheme_Array_To_C_Array(Scheme_Array);
- return C_Array_To_Scheme_Vector(Array, Length);
-}
-
-/* C_ARRAY */
-\f
-Pointer C_Array_To_Scheme_Array(Array, Length) REAL *Array; long Length;
-{ Pointer Result;
- long allocated_cells;
- Allocate_Array(Result, Length, allocated_cells);
- return Result;
-}
-\f
-Pointer C_Array_To_Scheme_Vector(Array, Length) REAL *Array; long Length;
-{ Pointer Result;
- Pointer *Now_Free;
- long i;
-
- Primitive_GC_If_Needed(Length+1 + Length*(FLONUM_SIZE+1));
- Now_Free = (Pointer *) Free;
- Free = Free + Length + 1; /* INCREMENT BEFORE ALLOCATING FLONUMS ! */
-
- Result = Make_Pointer(TC_VECTOR, Now_Free);
- *Now_Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
-
- for (i=0; i<Length; i++) {
- My_Store_Reduced_Flonum_Result( Array[i], *Now_Free);
- Now_Free++;
- }
- return Result;
-}
-
-\f
-/* SCHEME_VECTOR */
-
-Pointer Scheme_Vector_To_Scheme_Array(Arg1) Pointer Arg1;
-{ Pointer Result;
- long Length, allocated_cells;
- REAL *Array;
-
- Length = Vector_Length(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- Array = Scheme_Array_To_C_Array(Result);
-
- Scheme_Vector_To_C_Array(Arg1, Array);
- return Result;
-}
-
-\f
-void Scheme_Vector_To_C_Array(Scheme_Vector, Array)
- Pointer Scheme_Vector; REAL *Array;
-{ Pointer *From_Here;
- REAL *To_Here;
- long Length, i;
- int Error_Number;
-
- From_Here = Nth_Vector_Loc(Scheme_Vector, VECTOR_DATA);
- To_Here = Array;
- Length = Vector_Length(Scheme_Vector);
- for (i=0; i < Length; i++, From_Here++) {
- Error_Number = Scheme_Number_To_REAL(*From_Here, To_Here);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- To_Here++; /* this gets incremented by REAL_SIZE ! */
- }
-}
-
-/* END of ARRAY PROCESSING */
-\f
-/* one more hack for speed */
-
-/* (SOLVE-SYSTEM A B N)
- Solves the system of equations Ax = b. A and B are
- arrays and b is the order of the system. Returns x.
- From the Fortran procedure in Strang.
-*/
-
-Define_Primitive(Prim_Gaussian_Elimination, 2, "SOLVE-SYSTEM")
-{ REAL *A, *B, *X;
- long Length, allocated_cells;
- Pointer Result;
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Length = Array_Length(Arg2);
- if ((Length*Length) != Array_Length(Arg1)) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- A = Scheme_Array_To_C_Array(Arg1);
- B = Scheme_Array_To_C_Array(Arg2);
- Allocate_Array(Result, Length, allocated_cells);
- X = Scheme_Array_To_C_Array(Result);
- C_Array_Copy(B, X, Length);
- C_Gaussian_Elimination(A, X, Length);
- return Result;
-}
-
-/*
- C routine side-effects b.
-*/
-C_Gaussian_Elimination(a, b, n)
-REAL *a, *b;
-long n;
-{ long *pvt;
- REAL p, t;
- long i, j, k, m;
- Primitive_GC_If_Needed(n);
- pvt = ((long *) Free);
- *(pvt+n-1) = 1;
- if (n != 1) {
- for (k=1; k<n; k++) {
- m = k;
- for (i=k+1; i<=n; i++)
- if (fabs(*(a+i+(k-1)*n-1)) > fabs(*(a+m+(k-1)*n-1)))
- m = i;
- *(pvt+k-1) = m;
- if (m != k)
- *(pvt+n-1) = - *(pvt+n-1);
- p = *(a+m+(k-1)*n-1);
- *(a+m+(k-1)*n-1) = *(a+k+(k-1)*n-1);
- *(a+k+(k-1)*n-1) = p;
- if (p != 0.0) {
- for (i=k+1; i<=n; i++)
- *(a+i+(k-1)*n-1) = - *(a+i+(k-1)*n-1) / p;
- for (j=k+1; j<=n; j++) {
- t = *(a+m+(j-1)*n-1);
- *(a+m+(j-1)*n-1) = *(a+k+(j-1)*n-1);
- *(a+k+(j-1)*n-1) = t;
- if (t != 0.0)
- for (i=k+1; i<=n; i++)
- *(a+i+(j-1)*n-1) = *(a+i+(j-1)*n-1) + *(a+i+(k-1)*n-1) * t;
- }
- }
- }
- for (k=1; k<n; k++) {
- m = *(pvt+k-1);
- t = *(b+m-1);
- *(b+m-1) = *(b+k-1);
- *(b+k-1) = t;
- for (i=k+1; i<=n; i++)
- *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
- }
- for (j=1; j<n; j++) {
- k = n - j + 1;
- *(b+k-1) = *(b+k-1) / *(a+k+(k-1)*n-1);
- t = - *(b+k-1);
- for (i=1; i <= n-j; i++)
- *(b+i-1) = *(b+i-1) + *(a+i+(k-1)*n-1) * t;
- }
- }
- *b = *b / *a;
- return;
-}
-
-/* END OF FILE */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/array.h,v 9.22 1987/04/16 02:06:23 jinx Rel $ */
-\f
-/* The following two macros determine what kind of arrays we deal with.
- Use float to save space for image-processing
- */
-
-#define REAL float
-#define REAL_SIZE ((sizeof(Pointer)+sizeof(REAL)-1)/ sizeof(Pointer))
-
-
-/****************** Scheme_Array *****************/
-/* using NON_MARKED_VECTOR */
-/* This assumes that object.h is included also */
-
-#define TC_ARRAY TC_NON_MARKED_VECTOR
-#define TC_MANIFEST_ARRAY TC_MANIFEST_NM_VECTOR
-#define ARRAY_HEADER 0 /* NM_VECTOR_HEADER */
-/* contains the number of actual cells (words) allocated, used in gc */
-#define ARRAY_LENGTH 1 /* NM_ENTRY_COUNT */
-#define ARRAY_DATA 2 /* NM_DATA */
-#define ARRAY_HEADER_SIZE 2
-
-#define Array_Ref(P,N) ((Get_Pointer(P))[N+2])
-
-#define Nth_Array_Loc(P,N) (Scheme_Array_To_C_Array(P) + N)
-
-#define Scheme_Array_To_C_Array(Scheme_Array) \
- ((REAL *) Nth_Vector_Loc(Scheme_Array, ARRAY_DATA))
-
-#define Array_Length(Scheme_Array) \
- ((long) Vector_Ref(Scheme_Array, ARRAY_LENGTH))
-
-#define Allocate_Array(result, Length, allocated_cells) \
- allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE; \
- Primitive_GC_If_Needed(allocated_cells); \
- result = Make_Pointer(TC_ARRAY, Free); \
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1); \
- Free[ARRAY_LENGTH] = Length; \
- Free = Free+allocated_cells;
-
-\f
-/* SOME MORE MACROS */
-
-#define ARRAY_MAX_LENGTH 1000000 /* 4 Mbytes */
-
-#define Make_List_From_3_Pointers(pointer1, pointer2, pointer3, Result) \
-{ Primitive_GC_If_Needed(6); \
- Result = Make_Pointer(TC_LIST, Free); \
- *Free++ = pointer1; \
- *Free++ = Make_Pointer(TC_LIST, Free+1); \
- *Free++ = pointer2; \
- *Free++ = Make_Pointer(TC_LIST, Free+1); \
- *Free++ = pointer3; \
- *Free++ = NIL; \
-}
-
-#define Float_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
-{ REAL value; \
- int err; \
- err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
- if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
- if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
- variable = ((float) value); \
-}
-
-#define REAL_Range_Check(variable, Scheme_Pointer, Low, High, Error_Message) \
-{ REAL value; \
- int err; \
- err = Scheme_Number_To_REAL(Scheme_Pointer, &value); \
- if ((err == 1) || (err == 2)) Primitive_Error(Error_Message); \
- if ((value<Low) || (value>High)) Primitive_Error(Error_Message); \
- else variable = value; \
-}
-
-#define C_Make_Polar(Real, Imag, Mag_Cell, Phase_Cell) \
-{ double double_Real=((double) Real), double_Imag=((double) Imag); \
- Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \
- Phase_Cell = (REAL) atan2(double_Imag, double_Real); \
-}
-/* atan has no problem with division by zero */
-
-#define Linear_Map(slope,offset,From,To) { (To) = (((slope)*(From))+offset); }
-
-#define C_Find_Magnitude(Real, Imag, Mag_Cell) \
-{ double double_Real=((double) Real), double_Imag=((double) Imag); \
- Mag_Cell = (REAL) sqrt((double_Real*double_Real)+(double_Imag*double_Imag)); \
-}
-
-#define mabs(x) (((x)<0) ? -(x) : (x))
-#define max(x,y) (((x)<(y)) ? (y) : (x))
-#define min(x,y) (((x)<(y)) ? (x) : (y))
-
-
-/* FROM ARRAY.C */
-extern int Scheme_Number_To_REAL();
-extern int Scheme_Number_To_Double();
-extern void C_Array_Copy(); /* REAL *From_Array,*To_Array; long Length; */
-
-extern void C_Array_Find_Min_Max(); /* Find the index of the minimum (*nmin), maximum (*nmax). */
-extern void C_Array_Find_Average();
-extern void C_Array_Make_Histogram(); /* REAL *Array,*Histogram; long Length,npoints */
-
-\f
-/* DATATYPE CONVERSIONS */
-
-/* macro: REAL *Scheme_Array_To_C_Array(); */
-extern Pointer C_Array_To_Scheme_Array();
-/* there is also a macro: Allocate_Array(Result,Length,allocated_cells);
- */
-
-extern Pointer Scheme_Vector_To_Scheme_Array();
-extern Pointer Scheme_Array_To_Scheme_Vector();
-
-extern Pointer C_Array_To_Scheme_Vector();
-extern void Scheme_Vector_To_C_Array();
-/* Pointer Scheme_Vector; REAL *Array;
- */
-\f
-
-/* FROM BOB-XT.C */
-extern void Find_Offset_Scale_For_Linear_Map(); /* REAL Min,Max, New_Min,New_Max, *Offset,*Scale; */
-
-\f
-#define My_Store_Flonum_Result(Ans, Value_Cell) \
- (Value_Cell) = (Allocate_Float( ((double) Ans)));
-
-#define My_Store_Reduced_Flonum_Result(Ans, Value_Cell) \
-{ double Number = ((double) Ans); \
- double floor(); \
- Pointer result; \
- if (floor(Number) != Number) \
- { My_Store_Flonum_Result(Number, Value_Cell); \
- } \
- else if (Number == 0) \
- (Value_Cell) = Make_Unsigned_Fixnum(0); \
- if ((floor(Number) == Number) && (Number != 0)) \
- { int exponent; \
- double frexp(); \
- frexp(Number, &exponent); \
- if (exponent <= FIXNUM_LENGTH) \
- { double_into_fixnum(Number, result); \
- (Value_Cell) = result; \
- } \
- /* Since the float has no fraction, we will not gain \
- precision if its mantissa has enough bits to support \
- the exponent. */ \
- else if (exponent <= FLONUM_MANTISSA_BITS) \
- { result = Float_To_Big(Number); \
- (Value_Cell) = result; \
- } \
- else if (Number != 0) \
- { My_Store_Flonum_Result( (Ans), (Value_Cell)); \
- } \
- } \
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.28 1987/04/16 14:35:15 jinx Exp $ */
-
-/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
- purify, and fasdump, respectively, to provide garbage collection
- and related utilities to disk.
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-#define In_Fasdump
-#include "bchgcc.h"
-#include "dump.c"
-
-extern Pointer Make_Prim_Exts();
-
-/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
- Not implemented yet.
-*/
-
-Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
-{
- Primitive_3_Args();
-
- Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
- /*NOTREACHED*/
-}
-\f
-/* (DUMP-BAND PROCEDURE FILE-NAME)
- Saves all of the heap and pure space on FILE-NAME. When the
- file is loaded back using BAND_LOAD, PROCEDURE is called with an
- argument of NIL.
-*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
-{
- Pointer Combination, Ext_Prims;
- long Arg1Type;
- Primitive_2_Args();
-
- Band_Dump_Permitted();
- Arg1Type = Type_Code(Arg1);
- if ((Arg1Type != TC_CONTROL_POINT) &&
- (Arg1Type != TC_PRIMITIVE) &&
- (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
- (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
- Arg_2_Type(TC_CHARACTER_STRING);
- if (!Open_Dump_File(Arg2, WRITE_FLAG))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- /* Free cannot be saved around this code since Make_Prim_Exts will
- intern the undefined externals and potentially allocate space.
- */
- Ext_Prims = Make_Prim_Exts();
- Combination = Make_Pointer(TC_COMBINATION_1, Free);
- Free[COMB_1_FN] = Arg1;
- Free[COMB_1_ARG_1] = NIL;
- Free += 2;
- *Free++ = Combination;
- *Free++ = return_to_interpreter;
- *Free = Make_Pointer(TC_LIST, Free-2);
- Free++; /* Some compilers are TOO clever about this and increment Free
- before calculating Free-2! */
- *Free++ = Ext_Prims;
- /* Aligning here confuses some of the counts computed.
- Align_Float(Free);
- */
- Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2,
- ((long) (Free_Constant-Constant_Space)),
- Constant_Space, Free-1);
- fclose(File_Handle);
- return TRUTH;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.26 1987/02/12 01:17:47 jinx Exp $ */
-
-#include "gccode.h"
-
-/* All of these are in objects (Pointer), not bytes. */
-
-#define GC_EXTRA_BUFFER_SIZE 512
-#define GC_DISK_BUFFER_SIZE 4096
-#define GC_BUFFER_SPACE (GC_DISK_BUFFER_SIZE + GC_EXTRA_BUFFER_SIZE)
-#define GC_BUFFER_BYTES (GC_DISK_BUFFER_SIZE * sizeof(Pointer))
-
-#define GC_FILE_MASK 0644 /* Everyone reads, owner writes */
-#define GC_DEFAULT_FILE_NAME "/tmp/GCXXXXXX"
-
-extern Pointer *scan_buffer_top;
-extern Pointer *free_buffer_top;
-extern Pointer *dump_and_reload_scan_buffer();
-extern Pointer *dump_and_reset_free_buffer();
-extern void dump_free_directly();
-
-extern Pointer *GCLoop();
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcl.c,v 9.28 1987/04/16 02:06:42 jinx Exp $ */
-
-/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
- purify, and fasdump, respectively, to provide garbage collection
- and related utilities to disk.
-*/
-
-#include "scheme.h"
-#include "bchgcc.h"
-\f
-/* Some utility macros */
-
-#define copy_cell() \
-{ *To++ = *Old; \
-}
-
-#define copy_pair() \
-{ *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-#define copy_weak_pair() \
-{ long Car_Type; \
- \
- Car_Type = Type_Code(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
- Old += 1; \
- *To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
- Weak_Chain = Temp; \
-}
-
-#define copy_triple() \
-{ *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-#define copy_quadruple() \
-{ *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old++; \
- *To++ = *Old; \
-}
-
-/* Transporting vectors is done in 3 parts:
- - Finish filling the current free buffer, dump it, and get a new one.
- - Dump the middle of the vector directly by bufferfulls.
- - Copy the end of the vector to the new buffer.
- The last piece of code is the only one executed when the vector does
- not overflow the current buffer.
-*/
-
-#define copy_vector() \
-{ Pointer *Saved_Scan = Scan; \
- unsigned long real_length = 1 + Get_Integer(*Old); \
- \
- To_Address += real_length; \
- Scan = To + real_length; \
- if (Scan >= free_buffer_top) \
- { unsigned long overflow; \
- \
- overflow = Scan - free_buffer_top; \
- while (To != free_buffer_top) *To++ = *Old++; \
- To = dump_and_reset_free_buffer(0); \
- real_length = (overflow / GC_DISK_BUFFER_SIZE); \
- if (real_length > 0) dump_free_directly(Old, real_length); \
- Old += (real_length * GC_DISK_BUFFER_SIZE); \
- Scan = To + (overflow % GC_DISK_BUFFER_SIZE); \
- } \
- while (To != Scan) *To++ = *Old++; \
- Scan = Saved_Scan; \
-}
-\f
-#define relocate_normal_setup() \
-{ \
- Old = Get_Pointer(Temp); \
- if (Old >= Low_Constant) continue; \
- if (Type_Code(*Old) == TC_BROKEN_HEART) \
- { *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
- continue; \
- } \
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address)); \
-}
-
-#define relocate_normal_transport(copy_code, length) \
-{ copy_code; \
- To_Address += (length); \
- if (To >= free_buffer_top) \
- To = dump_and_reset_free_buffer(To - free_buffer_top); \
-}
-
-#define relocate_normal_end() \
-{ *Get_Pointer(Temp) = New_Address; \
- *Scan = Make_New_Pointer(Type_Code(Temp), New_Address); \
- continue; \
-}
-
-#define relocate_normal_pointer(copy_code, length) \
-{ relocate_normal_setup(); \
- relocate_normal_transport(copy_code, length); \
- relocate_normal_end(); \
-}
-\f
-Pointer
-*GCLoop(Scan, To_ptr, To_Address_ptr)
-fast Pointer *Scan;
-Pointer **To_ptr, **To_Address_ptr;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, *To_Address, New_Address;
-
- To = *To_ptr;
- To_Address = *To_Address_ptr;
- Low_Constant = Constant_Space;
-
- for ( ; Scan != To; Scan++)
- { Temp = *Scan;
- Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
- if (Scan != (Get_Pointer(Temp)))
- { fprintf(stderr, "GC: Broken heart in scan.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- if (Scan != scan_buffer_top) goto end_gcloop;
- /* The -1 is here because of the Scan++ in the for header. */
- Scan = dump_and_reload_scan_buffer(0) - 1;
- continue;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- /* Check whether this bumps over current buffer,
- and if so we need a new bufferfull. */
- Scan += Get_Integer(Temp);
- if (Scan < scan_buffer_top)
- break;
- else
- { unsigned long overflow;
- /* The + & -1 are here because of the Scan++ in the for header. */
- overflow = (Scan - scan_buffer_top) + 1;
- Scan = ((dump_and_reload_scan_buffer(overflow / GC_DISK_BUFFER_SIZE) +
- (overflow % GC_DISK_BUFFER_SIZE)) - 1);
- break;
- }
-
- case_Non_Pointer:
- break;
-
- case_compiled_entry_point:
- Old = Get_Pointer(Temp);
- if (Old >= Low_Constant) continue;
- Old = Get_Compiled_Block(Old);
- if (Type_Code(*Old) == TC_BROKEN_HEART)
- { *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old);
- continue;
- }
- else
- { Pointer *Saved_Old = Old;
- New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
- copy_vector();
- *Saved_Old = New_Address;
- *Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
- continue;
- }
-
- case_Cell:
- relocate_normal_pointer(copy_cell(), 1);
-
- case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
- break;
- }
- /* It is a pair, fall through. */
- case_Pair:
- relocate_normal_pointer(copy_pair(), 2);
-
- case TC_VARIABLE:
- case_Triple:
- relocate_normal_pointer(copy_triple(), 3);
-
- case_Quadruple:
- relocate_normal_pointer(copy_quadruple(), 4);
-
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- /* This must be fixed. */
-#include "error: bchgcl does not handle floating alignment."
-#else
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
- case_Vector:
- relocate_normal_setup();
- Move_Vector:
- copy_vector();
- relocate_normal_end();
-
- case TC_FUTURE:
- relocate_normal_setup();
- if (!(Future_Spliceable(Temp))) goto Move_Vector;
- *Scan = Future_Value(Temp);
- Scan -= 1;
- continue;
-
- case TC_WEAK_CONS:
- relocate_normal_pointer(copy_weak_pair(), 2);
-
- default:
- fprintf(stderr,
- "GCLoop: Bad type code = 0x%02x\n",
- Type_Code(Temp));
- Invalid_Type_Code();
- }
- }
-end_gcloop:
- *To_ptr = To;
- *To_Address_ptr = To_Address;
- return Scan;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.28 1987/04/16 02:06:52 jinx Exp $ */
-
-/* Memory management top level. Garbage collection to disk.
-
- The algorithm is basically the same as for the 2 space collector,
- except that new space is on the disk, and there are two windows to
- it (the scan and free buffers). For information on the 2 space
- collector, read the comments in the replaced files.
-
- The memory management code is spread over 3 files:
- - bchmmg.c: initialization and top level. Replaces memmag.c
- - bchgcl.c: main garbage collector loop. Replaces gcloop.c
- - bchpur.c: constant/pure space hacking. Replaces purify.c
- - bchdmp.c: object world image dumping. Replaces fasdump.c
-
- Problems with this implementation right now:
- - It only works on Unix (or systems which support Unix i/o calls).
- - Purify is not implemented.
- - Fasdump is not implemented.
- - Floating alignment is not implemented.
- - Dumpworld will not work because the file is not closed at dump time.
- - Command line supplied gc files are not locked, so two processes can try
- to share them.
- - Compiled code handling in bchgcl is not generic, may only work for 68k
- family processors.
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-#include "bchgcc.h"
-#include <fcntl.h>
-
-/* Exports */
-
-extern void Clear_Memory(), Setup_Memory(), Reset_Memory();
-\f
-/* Memory Allocation, sequential processor,
- garbage collection to disk version:
-
- ------------------------------------------
- | GC Buffer Space |
- | |
- ------------------------------------------
- | Control Stack || |
- | \/ |
- ------------------------------------------
- | Constant + Pure Space /\ |
- | || |
- ------------------------------------------
- | Heap Space |
- | |
- ------------------------------------------
-
- Each area has a pointer to its starting address and a pointer to
- the next free cell. The GC buffer space contains two equal size
- buffers used during the garbage collection process. Usually one is
- the scan buffer and the other is the free buffer, and they are
- dumped and loaded from disk as necessary. Sometimes during the
- garbage collection (especially at the beginning and at the end)
- both buffers are identical, since transporting will occur into the
- area being scanned.
-*/
-
-/* Local declarations */
-
-static long scan_position, free_position;
-static Pointer *gc_disk_buffer_1, *gc_disk_buffer_2;
-Pointer *scan_buffer_top, *scan_buffer_bottom, *scan_buffer;
-Pointer *free_buffer_top, *free_buffer_bottom, *free_buffer;
-\f
-/* Hacking the gc file */
-
-extern char *mktemp();
-
-static int gc_file;
-static char *gc_file_name;
-static char gc_default_file_name[FILE_NAME_LENGTH] = GC_DEFAULT_FILE_NAME;
-
-void
-open_gc_file()
-{
- int position;
- int flags;
-
- (void) mktemp(gc_default_file_name);
- flags = (O_RDWR | O_CREAT | O_SYNCIO);
-
- position = Parse_Option("-gcfile", Saved_argc, Saved_argv, true);
- if ((position != NOT_THERE) &&
- (position != (Saved_argc - 1)))
- {
- gc_file_name = Saved_argv[position + 1];
- }
- else
- {
- gc_file_name = gc_default_file_name;
- flags |= O_EXCL;
- }
-
- while(true)
- {
- gc_file = open(gc_file_name, flags, GC_FILE_MASK);
- if (gc_file != -1)
- break;
- if (gc_file_name != gc_default_file_name)
- {
- fprintf(stderr,
- "%s: GC file \"%s\" cannot be opened; ",
- Saved_argv[0]), gc_file_name;
- gc_file_name = gc_default_file_name;
- fprintf(stderr,
- "Using \"%s\" instead.\n",
- gc_file_name);
- flags |= O_EXCL;
- continue;
- }
- fprintf(stderr,
- "%s: GC file \"%s\" cannot be opened; ",
- Saved_argv[0]), gc_file_name;
- fprintf(stderr, "Aborting.\n");
- exit(1);
- }
- return;
-}
-
-void
-close_gc_file()
-{
- if (close(gc_file) == -1)
- fprintf(stderr,
- "%s: Problems closing GC file \"%s\".\n",
- Saved_argv[0], gc_file_name);
- if (gc_file_name == gc_default_file_name)
- unlink(gc_file_name);
- return;
-}
-\f
-void
-Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{
- Heap_Top = Heap_Bottom + Our_Heap_Size;
- Set_Mem_Top(Heap_Top - GC_Reserve);
- Free = Heap_Bottom;
- Free_Constant = Constant_Space;
- Set_Pure_Top();
- Initialize_Stack();
- return;
-}
-
-void
-Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{
- int Real_Stack_Size;
-
- Real_Stack_Size = Stack_Allocation_Size(Our_Stack_Size);
-
- /* Consistency check 1 */
- if (Our_Heap_Size == 0)
- {
- fprintf(stderr, "Configuration won't hold initial data.\n");
- exit(1);
- }
-
- /* Allocate.
- The two GC buffers are not included in the valid Scheme memory.
- */
- Highest_Allocated_Address =
- Allocate_Heap_Space(Real_Stack_Size + Our_Heap_Size +
- Our_Constant_Size + (2 * GC_BUFFER_SPACE) +
- HEAP_BUFFER_SPACE);
-
- /* Consistency check 2 */
- if (Heap == NULL)
- {
- fprintf(stderr, "Not enough memory for this configuration.\n");
- exit(1);
- }
-
- /* Trim the system buffer space. */
-
- Highest_Allocated_Address -= (2 * GC_BUFFER_SPACE);
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
-
- Constant_Space = Heap + Our_Heap_Size;
- gc_disk_buffer_1 = Constant_Space + Our_Constant_Size + Real_Stack_Size;
- gc_disk_buffer_2 = (gc_disk_buffer_1 + GC_BUFFER_SPACE);
-
- /* Consistency check 3 */
- if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0)
- {
- fprintf(stderr,
- "Largest address does not fit in datum field of Pointer.\n");
- fprintf(stderr,
- "Allocate less space or re-compile without Heap_In_Low_Memory.\n");
- exit(1);
- }
-
- Heap_Bottom = Heap;
- Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
-
- open_gc_file();
- return;
-}
-
-void
-Reset_Memory()
-{
- close_gc_file();
- return;
-}
-\f
-void
-dump_buffer(from, position, nbuffers, name)
- Pointer *from;
- long *position, nbuffers;
- char *name;
-{
- long bytes_written;
-
- if (lseek(gc_file, *position, 0) == -1)
- {
- fprintf(stderr,
- "\nCould not position GC file to write the %s buffer.\n",
- name);
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- if ((bytes_written = write(gc_file, from, (nbuffers * GC_BUFFER_BYTES))) ==
- -1)
- {
- fprintf(stderr, "\nCould not write out the %s buffer.\n", name);
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
-
- *position += bytes_written;
- return;
-}
-
-void
-load_buffer(position, to, nbytes, name)
- long position;
- Pointer *to;
- long nbytes;
- char *name;
-{
- long bytes_read;
-
- if (lseek(gc_file, position, 0) == -1)
- {
- fprintf(stderr, "\nCould not position GC file to read %s.\n", name);
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- if ((bytes_read = read(gc_file, to, nbytes)) != nbytes)
- {
- fprintf(stderr, "\nCould not read into %s.\n", name);
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- return;
-}
-
-void
-reload_scan_buffer()
-{
- if (scan_position == free_position)
- {
- scan_buffer_bottom = free_buffer_bottom;
- scan_buffer_top = free_buffer_top;
- scan_buffer = scan_buffer_bottom;
- return;
- }
- scan_buffer_bottom = ((free_buffer_bottom == gc_disk_buffer_1) ?
- gc_disk_buffer_2 :
- gc_disk_buffer_1);
- load_buffer(scan_position, scan_buffer_bottom,
- GC_BUFFER_BYTES, "the scan buffer");
- scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
- return;
-}
-\f
-void
-initialize_scan_buffer()
-{
- scan_position = 0;
- reload_scan_buffer();
- scan_buffer = scan_buffer_bottom;
- return;
-}
-
-/* This hacks the scan buffer also so that Scan is always below
- scan_buffer_top until the scan buffer is initialized.
-*/
-void
-initialize_free_buffer()
-{
- free_position = 0;
- free_buffer_bottom = gc_disk_buffer_1;
- free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
- free_buffer = free_buffer_bottom;
- scan_position = -1;
- scan_buffer_bottom = gc_disk_buffer_2;
- scan_buffer_top = scan_buffer_bottom + GC_DISK_BUFFER_SIZE;
- return;
-}
-
-Pointer *
-dump_and_reload_scan_buffer(number_to_skip)
- long number_to_skip;
-{
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
- if (number_to_skip != 0)
- scan_position += (number_to_skip * GC_BUFFER_BYTES);
- reload_scan_buffer();
- return scan_buffer_bottom;
-}
-
-Pointer *
-dump_and_reset_free_buffer(overflow)
- fast long overflow;
-{
- fast Pointer *into, *from;
-
- from = free_buffer_top;
- if (free_buffer_bottom == scan_buffer_bottom)
- {
- /* No need to dump now, it will be dumped when scan is dumped.
- Does this work?
- We may need to dump the buffer anyway so we can dump the next one.
- It may not be possible to lseek past the end of file.
- */
- free_position += GC_BUFFER_BYTES;
- free_buffer_bottom = ((scan_buffer_bottom == gc_disk_buffer_1) ?
- gc_disk_buffer_2 :
- gc_disk_buffer_1);
- free_buffer_top = free_buffer_bottom + GC_DISK_BUFFER_SIZE;
- }
- else
- dump_buffer(free_buffer_bottom, &free_position, 1, "free");
-
- for (into = free_buffer_bottom; --overflow >= 0; )
- *into++ = *from++;
-
- /* This only needs to be done when they were the same buffer,
- but it does not hurt.
- */
- *scan_buffer_top = Make_Pointer(TC_BROKEN_HEART, scan_buffer_top);
-
- return into;
-}
-
-void
-dump_free_directly(from, nbuffers)
- Pointer *from;
- long nbuffers;
-{
- dump_buffer(from, &free_position, nbuffers, "free");
- return;
-}
-\f
-static long current_buffer_position;
-
-void
-initialize_new_space_buffer()
-{
- current_buffer_position = -1;
- return;
-}
-
-void
-flush_new_space_buffer()
-{
- if (current_buffer_position == -1)
- return;
- dump_buffer(gc_disk_buffer_1, ¤t_buffer_position,
- 1, "weak pair buffer");
- current_buffer_position = -1;
- return;
-}
-
-Pointer *
-guarantee_in_memory(addr)
- Pointer *addr;
-{
- long position, offset;
-
- position = (addr - Heap_Bottom);
- offset = (position % GC_DISK_BUFFER_SIZE);
- position = (position / GC_DISK_BUFFER_SIZE);
- position *= GC_BUFFER_BYTES;
- if (position != current_buffer_position)
- {
- flush_new_space_buffer();
- load_buffer(position, gc_disk_buffer_1,
- GC_BUFFER_BYTES, "the weak pair buffer");
- current_buffer_position = position;
- }
- return &gc_disk_buffer_1[offset];
-}
-\f
-/* For a description of the algorithm, see memmag.c.
- This has been modified only to account for the fact that new space
- is on disk. Old space is in memory.
-*/
-
-Pointer Weak_Chain;
-
-void
-Fix_Weak_Chain()
-{
- fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
-
- initialize_new_space_buffer();
- Low_Constant = Constant_Space;
- while (Weak_Chain != NIL)
- {
- Old_Weak_Cell = Get_Pointer(Weak_Chain);
- Scan = guarantee_in_memory(Get_Pointer(*Old_Weak_Cell++));
- Weak_Chain = *Old_Weak_Cell;
- Old_Car = *Scan;
- Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car);
- Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
-
- switch(GC_Type(Temp))
- { case GC_Non_Pointer:
- *Scan = Temp;
- continue;
-
- case GC_Special:
- if (Type_Code(Temp) != TC_REFERENCE_TRAP)
- {
- /* No other special type makes sense here. */
- goto fail;
- }
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- *Scan = Temp;
- continue;
- }
- /* Otherwise, it is a pointer. Fall through */
-
- /* Normal pointer types, the broken heart is in the first word.
- Note that most special types are treated normally here.
- The BH code updates *Scan if the object has been relocated.
- Otherwise it falls through and we replace it with a full NIL.
- Eliminating this assignment would keep old data (pl. of datum).
- */
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- /* Old is still a pointer to old space */
- Old = Get_Pointer(Old_Car);
- if (Old >= Low_Constant)
- {
- *Scan = Temp;
- continue;
- }
- if (Type_Code(*Old) == TC_BROKEN_HEART)
- {
- *Scan = Make_New_Pointer(Type_Code(Temp), *Old);
- continue;
- }
- *Scan = NIL;
- continue;
-
- case GC_Compiled:
- /* Old is still a pointer to old space */
- Old = Get_Pointer(Old_Car);
- if (Old >= Low_Constant)
- {
- *Scan = Temp;
- continue;
- }
- /* Ditto */
- Old = Get_Compiled_Block(Old);
- if (Type_Code(*Old) == TC_BROKEN_HEART)
- {
- *Scan = Relocate_Compiled(Temp, Get_Pointer(*Old), Old);
- continue;
- }
- *Scan = NIL;
- continue;
-
- case GC_Undefined:
- default: /* Non Marked Headers and Broken Hearts */
- fail:
- fprintf(stderr,
- "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
- Type_Code(Temp), Datum(Temp));
- Microcode_Termination(TERM_INVALID_TYPE_CODE);
- /*NOTREACHED*/
- }
- }
- flush_new_space_buffer();
- return;
-}
-\f
-void
-GC()
-{
- Pointer *Root, *Result, *end_of_constant_area,
- The_Precious_Objects, *Root2;
-
- initialize_free_buffer();
- Free = Heap_Bottom;
- Set_Mem_Top(Heap_Top - GC_Reserve);
- Weak_Chain = NIL;
-
- /* Save the microcode registers so that they can be relocated */
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(end_of_constant_area);
-
- Root = Free;
- The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
- Set_Fixed_Obj_Slot(Precious_Objects, NIL);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL);
-
- *free_buffer++ = Fixed_Objects;
- *free_buffer++ = Make_Pointer(TC_HUNK3, History);
- *free_buffer++ = Undefined_Externals;
- *free_buffer++ = Get_Current_Stacklet();
- *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
- NIL :
- Make_Pointer(TC_CONTROL_POINT,
- Prev_Restore_History_Stacklet));
- *free_buffer++ = Current_State_Point;
- *free_buffer++ = Fluid_Bindings;
- Free += (free_buffer - free_buffer_bottom);
- if (free_buffer >= free_buffer_top)
- free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top);
-\f
- /* The 4 step GC */
- Result = GCLoop(Constant_Space, &free_buffer, &Free);
- if (Result != end_of_constant_area)
- {
- fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- initialize_scan_buffer();
- Result = GCLoop(scan_buffer, &free_buffer, &Free);
- if (free_buffer != Result)
- {
- fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- Root2 = Free;
- *free_buffer++ = The_Precious_Objects;
- Free += (free_buffer - Result);
- if (free_buffer >= free_buffer_top)
- free_buffer = dump_and_reset_free_buffer(free_buffer - free_buffer_top);
- Result = GCLoop(Result, &free_buffer, &Free);
- if (free_buffer != Result)
- {
- fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
- }
- dump_buffer(scan_buffer_bottom, &scan_position, 1, "scan");
- free_position = scan_position;
- Fix_Weak_Chain();
- load_buffer(0, Heap_Bottom,
- ((Free - Heap_Bottom) * sizeof(Pointer)),
- "new space");
-
- /* Make the microcode registers point to the copies in new-space. */
-
- Fixed_Objects = *Root++;
- Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
-
- History = Get_Pointer(*Root++);
- Undefined_Externals = *Root++;
- Set_Current_Stacklet(*Root);
- Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
- if (*Root == NIL)
- {
- Prev_Restore_History_Stacklet = NULL;
- Root += 1;
- }
- else
- Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
- Current_State_Point = *Root++;
- Fluid_Bindings = *Root++;
- Free_Stacklets = NULL;
- return;
-}
-\f
-/* (GARBAGE-COLLECT SLACK)
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by invoking
- the GC daemon if there is one.
-*/
-
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
-{
- Pointer GC_Daemon_Proc;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- if (Free > Heap_Top)
- {
- fprintf(stderr,
- "\nGC has been delayed too long; You are truly out of room!\n");
- fprintf(stderr,
- "Free = 0x%x, MemTop = 0x%x, Heap_Top = 0x%x\n",
- Free, MemTop, Heap_Top);
- Microcode_Termination(TERM_NO_SPACE);
- /*NOTREACHED*/
- }
- GC_Reserve = Get_Integer(Arg1);
- GC();
- IntCode &= ~INT_GC;
- if (GC_Check(GC_Space_Needed))
- {
- fprintf(stderr, "\nGC just ended.\n");
- fprintf(stderr,
- "Free = 0x%x; MemTop = 0x%x; GC_Space_Needed = 0x%x.\n",
- Free, MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_NO_SPACE);
- /*NOTREACHED*/
- }
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
- return Make_Unsigned_Fixnum(MemTop - Free);
- Pop_Primitive_Frame(1);
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
- Save_Cont();
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /* The following comment is by courtesy of LINT, your friendly sponsor. */
- /*NOTREACHED*/
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.27 1987/04/16 02:07:10 jinx Exp $
- *
- * This file contains the code for primitives dealing with pure
- * and constant space. Garbage collection to disk version.
- *
- * Currently this is not implemented. These are just stubs.
- *
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "bchgcc.h"
-\f
-/* Stub. Terminates Scheme if invoked. */
-
-Pointer
-Purify_Pass_2(info)
-Pointer info;
-{
- fprintf(stderr, "\nPurify_Pass_2 invoked!\n");
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
-}
-
-/* Stub. Make it look as if it had succeeded. */
-
-Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
-{
- Primitive_2_Args();
-
- return TRUTH;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.23 1987/04/16 02:08:22 jinx Rel $
-
- This file contains the procedures for handling BIGNUM Arithmetic.
-*/
-
-#include "scheme.h"
-#include <math.h>
-#include "primitive.h"
-#include "bignum.h"
-#include "flonum.h"
-#include "zones.h"
-\f
-/* General Purpose Utilities */
-
-Pointer
-return_bignum_zero()
-{
- bigdigit *REG;
- long Align_0 = Align(0);
- Primitive_GC_If_Needed(Align_0);
- REG = BIGNUM(Free);
- Prepare_Header(REG, 0, POSITIVE);
- Free += Align_0;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
-}
-
-void
-trim_bignum(ARG)
- bigdigit *ARG;
-{
- fast bigdigit *SCAN;
- fast bigdigit size;
- bigdigit sign;
-
- sign = SIGN(ARG);
- size = LEN(ARG);
-
- for (SCAN = Bignum_Top(ARG); ((size != 0) && (*SCAN == 0)); SCAN--)
- size -= 1;
-
- if (size == 0)
- sign = POSITIVE;
- Prepare_Header(ARG, size, sign);
- return;
-}
-
-void
-copy_bignum(SOURCE, TARGET)
- fast bigdigit *SOURCE, *TARGET;
-{
- fast bigdigit *LIMIT;
-
- LIMIT = Bignum_Top(SOURCE);
- while (LIMIT >= SOURCE)
- *TARGET++ = *SOURCE++;
- return;
-}
-
-long
-Find_Length(pradix, length)
- fast long pradix;
- bigdigit length;
-{
- fast int log_pradix;
-
- log_pradix = 0;
- while (pradix != 1)
- {
- pradix = pradix >> 1;
- log_pradix += 1;
- }
- return (((SHIFT / log_pradix) + 1) * length);
-}
-\f
-/* scale() and unscale() used by Division and Listify */
-
-void
-scale(SOURCE, DEST, how_much)
- fast bigdigit *SOURCE, *DEST;
- fast long how_much;
-{
- fast unsigned bigdouble prod = 0;
- bigdigit *LIMIT;
-
- if (how_much == 1)
- {
- if (SOURCE != DEST)
- copy_bignum(SOURCE, DEST);
- Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE));
- *Bignum_Top(DEST) = 0;
- return;
- }
-
- /* This must happen before the Prepare_Header if DEST = SOURCE */
-
- LIMIT = Bignum_Top(SOURCE);
- Prepare_Header(DEST, (LEN(SOURCE) + 1), SIGN(SOURCE));
- SOURCE = Bignum_Bottom(SOURCE);
- DEST = Bignum_Bottom(DEST);
- while (LIMIT >= SOURCE)
- {
- prod = *SOURCE++ * how_much + Get_Carry(prod);
- *DEST++ = Get_Digit(prod);
- }
- *DEST = Get_Carry(prod);
- return;
-}
-
-/* returns remainder */
-
-long
-unscale(SOURCE, DEST, how_much)
- bigdigit *SOURCE;
- fast bigdigit *DEST;
- fast long how_much;
-{
- bigdigit carry = 0;
- fast unsigned bigdouble digits;
- fast bigdigit *SCAN;
-
- if (how_much == 1)
- {
- if (SOURCE != DEST)
- copy_bignum(SOURCE, DEST);
- return 0;
- }
- Prepare_Header(DEST, LEN(SOURCE), SIGN(DEST));
- SCAN = Bignum_Top(SOURCE);
- DEST = Bignum_Top(DEST);
- SOURCE = Bignum_Bottom(SOURCE);
- while (SCAN >= SOURCE)
- {
- /* Bug fix by JMiller */
- fast unsigned bigdouble digits, temp;
-
- digits = Mul_Radix(carry) + *SCAN--;
- temp = digits / how_much;
- *DEST-- = temp;
- temp = temp * how_much;
- carry = digits - temp;
- }
- return carry;
-}
-\f
-/* Bignum Comparison utilities */
-
-/* big_compare_unsigned() compares the magnitudes of two BIGNUM's.
- * Called by big_compare() and minus_unsigned_bignum().
- */
-
-int
-big_compare_unsigned(ARG1, ARG2)
- fast bigdigit *ARG1, *ARG2;
-{
- fast bigdigit *LIMIT;
-
- if ((LEN(ARG1)) > (LEN(ARG2))) return ONE_BIGGER;
- if ((LEN(ARG1)) < (LEN(ARG2))) return TWO_BIGGER;
- if ((LEN(ARG1)) == 0) return EQUAL;
- LIMIT = Bignum_Bottom(ARG1);
- ARG1 = Bignum_Top(ARG1);
- ARG2 = Bignum_Top(ARG2);
- while (ARG1 >= LIMIT)
- { if (*ARG1 > *ARG2) return ONE_BIGGER;
- if (*ARG1 < *ARG2) return TWO_BIGGER;
- ARG1 -= 1;
- ARG2 -= 1;
- }
- return EQUAL;
-}
-
-/* big_compare() will return either of three cases, determining whether
- * ARG1 is bigger, smaller, or equal to ARG2.
- */
-
-Pointer
-big_compare(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{
- switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_NEGATIVE : return big_compare_unsigned(ARG2, ARG1);
- case BOTH_POSITIVE : return big_compare_unsigned(ARG1, ARG2);
- case ARG1_NEGATIVE : return TWO_BIGGER;
- case ARG2_NEGATIVE : return ONE_BIGGER;
- default: Sign_Error("big_compare()");
- }
- /*NOTREACHED*/
-}
-\f
-Pointer
-Fix_To_Big(Arg1)
- Pointer Arg1;
-{
- fast bigdigit *Answer, *SCAN, *size;
- long Length, ARG1;
-
- if (Type_Code(Arg1) != TC_FIXNUM) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Get_Integer(Arg1) == 0)
- { long Align_0 = Align(0);
- bigdigit *REG;
- Primitive_GC_If_Needed(2);
- REG = BIGNUM(Free);
- Prepare_Header(REG, 0, POSITIVE);
- Free += Align_0;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Align_0);
- }
- Length = Align(FIXNUM_LENGTH_AS_BIGNUM);
- Primitive_GC_If_Needed(Length);
- Sign_Extend(Arg1, ARG1);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, 0, (ARG1 >= 0) ? POSITIVE : NEGATIVE);
- size = &LEN(Answer);
- if (ARG1 < 0) ARG1 = - ARG1;
- for (SCAN = Bignum_Bottom(Answer); ARG1 != 0; *size += 1)
- { *SCAN++ = Rem_Radix(ARG1);
- ARG1 = Div_Radix(ARG1);
- }
- Length = Align(*size);
- *((Pointer *) Answer) = Make_Header(Length);
- Free += Length;
- Debug_Test(Free-Length);
- return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
-}
-\f
-Pointer
-Big_To_Fix (bignum_object)
- Pointer bignum_object;
-{
- fast bigdigit *bptr, *scan;
- fast long result, i;
- long Length;
-
- if ((Type_Code (bignum_object)) != TC_BIG_FIXNUM)
- return (bignum_object);
- bptr = BIGNUM (Get_Pointer (bignum_object));
- Length = LEN (bptr);
- if (Length == 0)
- return (Make_Unsigned_Fixnum(0));
- if (Length > FIXNUM_LENGTH_AS_BIGNUM)
- return (bignum_object);
-
- scan = Bignum_Top (bptr);
- result = *scan--;
-
- if (result < 0)
- return (bignum_object);
-
- if (Length == FIXNUM_LENGTH_AS_BIGNUM)
- {
- long saved_result, length_in_bits;
-
- saved_result = result;
-
- for (i = 0; result != 0; i+= 1)
- result = result >> 1;
-
- length_in_bits = i + ((Length == 0) ? 0 : ((Length - 1) * SHIFT));
-
- if (length_in_bits > FIXNUM_LENGTH)
- return (bignum_object);
-
- result = (saved_result &
- ((1 << ((FIXNUM_LENGTH + 1) -
- ((FIXNUM_LENGTH + 1) % SHIFT))) - 1));
-
- }
-
- for (i = (Length - 1); (i > 0); i -= 1)
- result = (Mul_Radix (result) + *scan--);
-
- if (result < 0)
- return (bignum_object);
- if (NEG_BIGNUM (bptr))
- result = (- result);
- return (Fixnum_Fits (result)
- ? Make_Signed_Fixnum (result)
- : bignum_object);
-}
-\f
-Boolean
-Fits_Into_Flonum(Bignum)
- bigdigit *Bignum;
-{
- fast int k;
- quick bigdigit top_digit;
-
- k = (LEN(Bignum) - 1) * SHIFT;
- for (top_digit = *Bignum_Top(Bignum); top_digit != 0; k++)
- top_digit >>= 1;
-
-/* If precision should not be lost,
- if (k <= FLONUM_MANTISSA_BITS) return true;
- Otherwise,
-*/
-
- if (k <= MAX_FLONUM_EXPONENT) return true;
- return false;
-}
-
-Pointer
-Big_To_Float(Arg1)
- Pointer Arg1;
-{
- fast bigdigit *ARG1, *LIMIT;
- fast double F = 0.0;
-
- ARG1 = BIGNUM(Get_Pointer(Arg1));
- if (!Fits_Into_Flonum(ARG1)) return Arg1;
- Primitive_GC_If_Needed(FLONUM_SIZE+1);
- LIMIT = Bignum_Bottom(ARG1);
- ARG1 = Bignum_Top(ARG1);
- while (ARG1 >= LIMIT) F = (F * ((double) RADIX)) + ((double) *ARG1--);
- if (NEG_BIGNUM(BIGNUM(Get_Pointer(Arg1)))) F = -F;
- return Allocate_Float(F);
-}
-
-\f
-#ifdef HAS_FREXP
-extern double frexp(), ldexp();
-#else
-#include "missing.c"
-#endif
-
-Pointer
-Float_To_Big(flonum)
- double flonum;
-{
- fast double mantissa;
- fast bigdigit *Answer, size;
- int exponent;
- long Align_size;
-
- if (flonum == 0.0)
- return return_bignum_zero();
- mantissa = frexp(flonum, &exponent);
- if (flonum < 0) mantissa = -mantissa;
- if (mantissa >= 1.0)
- { mantissa = mantissa/2.0;
- exponent += 1;
- }
- size = (exponent + (SHIFT - 1)) / SHIFT;
- exponent = exponent % SHIFT;
- mantissa = ldexp(mantissa, (exponent == 0) ? 0: exponent - SHIFT);
- Align_size = Align(size);
- Primitive_GC_If_Needed(Align_size);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, size, (flonum < 0) ? NEGATIVE : POSITIVE);
- Answer = Bignum_Top(Answer)+1;
- while ((size > 0) && (mantissa != 0))
- {
- long temporary;
-
- mantissa = mantissa * ((double) RADIX);
- /* explicit intermediate required by compiler bug. -- cph */
- temporary = ((long) mantissa);
- *--Answer = ((bigdigit) temporary);
- mantissa = mantissa - ((double) *Answer);
- size -= 1;
- }
- while (size-- != 0) *--Answer = (bigdigit) 0;
- Free += Align_size;
- Debug_Test(Free-Align_size);
- return Make_Pointer(TC_BIG_FIXNUM, Free-Align_size);
-}
-\f
-Pointer
-plus_unsigned_bignum(ARG1, ARG2, sign)
- fast bigdigit *ARG1, *ARG2;
- bigdigit sign;
-{
- fast unsigned bigdouble Sum;
- long Size;
- fast bigdigit *Answer;
- fast bigdigit *TOP2, *TOP1;
-
- /* Swap ARG1 and ARG2 so that ARG1 is always longer */
-
- if (LEN(ARG1) < LEN(ARG2))
- {
- Answer = ARG1;
- ARG1 = ARG2;
- ARG2 = Answer;
- }
-
- /* Allocate Storage and do GC if needed */
-
- Size = Align(LEN(ARG1) + 1);
- Primitive_GC_If_Needed(Size);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, (LEN(ARG1) + 1), sign);
-
- /* Prepare Scanning Pointers and delimiters */
-
- TOP1 = Bignum_Top(ARG1);
- TOP2 = Bignum_Top(ARG2);
- ARG1 = Bignum_Bottom(ARG1);
- ARG2 = Bignum_Bottom(ARG2);
- Answer = Bignum_Bottom(Answer);
- Sum = 0;
-\f
- /* Starts Looping */
-
- while (TOP2 >= ARG2)
- {
- Sum = *ARG1++ + *ARG2++ + Get_Carry(Sum);
- *Answer++ = Get_Digit(Sum);
- }
-
- /* Let remaining carry propagate */
-
- while ((TOP1 >= ARG1) && (Get_Carry(Sum) != 0))
- {
- Sum = *ARG1++ + 1;
- *Answer++ = Get_Digit(Sum);
- }
-
- /* Copy rest of ARG1 into Answer */
- while (TOP1 >= ARG1)
- *Answer++ = *ARG1++;
- *Answer = Get_Carry(Sum);
-
- /* Trims Answer. The trim function is not used because there is at
- * most one leading zero.
- */
-
- if (*Answer == 0)
- {
- Answer = BIGNUM(Free);
- LEN(Answer) -= 1;
- *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
- }
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
-}
-\f
-Pointer
-minus_unsigned_bignum(ARG1, ARG2, sign)
- fast bigdigit *ARG1, *ARG2;
- bigdigit sign;
-{
- fast bigdouble Diff;
- fast bigdigit *Answer, *TOP2, *TOP1;
- long Size;
-
- if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
- {
- Answer = ARG1;
- ARG1 = ARG2;
- ARG2 = Answer;
- sign = !sign;
- }
-
- Size = Align(LEN(ARG1));
- Primitive_GC_If_Needed(Size);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, LEN(ARG1), sign);
-
- TOP1 = Bignum_Top(ARG1);
- TOP2 = Bignum_Top(ARG2);
- ARG1 = Bignum_Bottom(ARG1);
- ARG2 = Bignum_Bottom(ARG2);
- Answer = Bignum_Bottom(Answer);
- Diff = RADIX;
-
- /* Main loops for minus_unsigned_bignum */
-
- while (TOP2 >= ARG2)
- {
- Diff = *ARG1++ + (MAX_DIGIT_SIZE - *ARG2++) + Get_Carry(Diff);
- *Answer++ = Get_Digit(Diff);
- }
-
- while ((TOP1 >= ARG1) && (Get_Carry(Diff) == 0))
- {
- Diff = *ARG1++ + MAX_DIGIT_SIZE;
- *Answer++ = Get_Digit(Diff);
- }
-
- while (TOP1 >= ARG1)
- *Answer++ = *ARG1++;
- trim_bignum((bigdigit *) Free);
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
-}
-\f
-/* Addition */
-
-Pointer
-plus_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{ /* Special Case for answer being zero */
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return return_bignum_zero();
- switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_POSITIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case ARG1_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
- case ARG2_NEGATIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case BOTH_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
- default : Sign_Error("plus_bignum()");
- }
- /*NOTREACHED*/
-}
-
-/* Subtraction */
-
-Pointer
-minus_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{
- /* Special Case for answer being zero */
-
- if (ZERO_BIGNUM(ARG1) && ZERO_BIGNUM(ARG2))
- return return_bignum_zero();
-
- /* Dispatches According to Sign of Args */
-
- switch(Categorize_Sign(ARG1, ARG2))
- { case BOTH_POSITIVE : return(minus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case ARG1_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, NEGATIVE));
- case ARG2_NEGATIVE : return(plus_unsigned_bignum(ARG1, ARG2, POSITIVE));
- case BOTH_NEGATIVE : return(minus_unsigned_bignum(ARG2, ARG1, POSITIVE));
- default : Sign_Error("minus_bignum()");
- }
- /*NOTREACHED*/
-}
-\f
-/* Multiplication */
-
-Pointer
-multiply_unsigned_bignum(ARG1, ARG2, sign)
- fast bigdigit *ARG1, *ARG2;
- bigdigit sign;
-{
- bigdigit *TOP1, *TOP2;
- fast bigdigit *Answer;
- fast bigdouble Prod;
- fast int size;
- long Size;
-
- Prod = LEN(ARG1) + LEN(ARG2);
- Size = Align(Prod);
- Primitive_GC_If_Needed(Size);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, Prod, sign);
- TOP1 = Bignum_Top(Answer);
- TOP2 = Bignum_Bottom(Answer);
- while (TOP1 >= TOP2)
- *TOP2++ = 0;
-
- /* Main loops for MULTIPLY */
-
- size = LEN(ARG2);
- Answer = Bignum_Bottom(Answer) + size;
- TOP1 = Bignum_Top(ARG1);
- TOP2 = Bignum_Top(ARG2);
- ARG2 = TOP2;
-\f
- for (ARG1 = Bignum_Bottom(ARG1); TOP1 >= ARG1; ARG1++, Answer++)
- {
- if (*ARG1 != 0)
- {
- Prod = 0;
- Answer -= size;
- for (ARG2 = TOP2 - size + 1; TOP2 >= ARG2; ++ARG2)
- {
- Prod = *ARG1 * *ARG2 + *Answer + Get_Carry(Prod);
- *Answer++ = Get_Digit(Prod);
- }
- *Answer = Get_Carry(Prod);
- }
- }
-
- /* Trims Answer */
-
- Answer = BIGNUM(Free);
- if (*(Bignum_Top(Answer)) == 0)
- {
- LEN(Answer) -= 1;
- *((Pointer *) Answer) = Make_Header(Align(LEN(Answer)));
- }
- Free += Size;
- return Make_Pointer(TC_BIG_FIXNUM, Free-Size);
-}
-
-Pointer
-multiply_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{
- if (ZERO_BIGNUM(ARG1) || ZERO_BIGNUM(ARG2))
- return return_bignum_zero();
-
- switch(Categorize_Sign(ARG1,ARG2))
- { case BOTH_POSITIVE :
- case BOTH_NEGATIVE :
- return multiply_unsigned_bignum(ARG1, ARG2, POSITIVE);
- case ARG1_NEGATIVE :
- case ARG2_NEGATIVE :
- return multiply_unsigned_bignum(ARG1, ARG2, NEGATIVE);
- default : Sign_Error("multiply_bignum()");
- }
- /*NOTREACHED*/
-}
-\f
-/* This is the guts of the division algorithm. The storage
- * allocation and other hairy prep work is done in the superior
- * routines. ARG1 and ARG2 are fresh copies, ARG1 will
- * ultimately become the Remainder. Storage already
- * allocated for all four parameters.
- */
-
-static Pointer BIG_A[TEMP_SIZE], BIG_B[TEMP_SIZE];
-
-Pointer
-div_internal(ARG1, ARG2, Quotient)
- bigdigit *ARG1, *ARG2, *Quotient;
-{
- fast bigdigit *SCAN,*PROD;
- fast bigdouble Digit, Prod;
- fast bigdouble guess, dvsr2, dvsr1;
- fast bigdigit *LIMIT, *QUOT_SCAN;
- bigdigit *Big_A, *Big_B;
-
- Big_A = BIGNUM(BIG_A);
- Big_B = BIGNUM(BIG_B);
- SCAN = Bignum_Top(ARG2);
- if (*SCAN == 0)
- { LEN(ARG2) -= 1;
- SCAN -= 1;
- }
- dvsr1 = *SCAN--;
- dvsr2 = *SCAN;
-
- Prepare_Header(Quotient, (LEN(ARG1)-LEN(ARG2)), POSITIVE);
-
- QUOT_SCAN = Bignum_Top(Quotient);
- ARG1 = Bignum_Top(ARG1);
- SCAN = ARG1 - LEN(ARG2);
- Quotient = Bignum_Bottom(Quotient);
-\f
- /* Main Loop for div_internal() */
-
- while (QUOT_SCAN >= Quotient)
- {
- if (dvsr1 <= *ARG1) guess = RADIX - 1;
- else
- { /* This should be
- * guess = (Mul_Radix(*ARG1) + *(ARG1 - 1)) / dvsr1;
- * but because of overflow problems ...
- */
-
- Prepare_Header(Big_A, 2, POSITIVE);
- *Bignum_Top(Big_A) = *ARG1;
- *Bignum_Bottom(Big_A) = *(ARG1-1);
- unscale(Big_A, Big_A, dvsr1);
- guess = *Bignum_Bottom(Big_A);
- }
- guess += 1; /* To counter first decrementing below. */
- do
- {
- guess -= 1;
- Prepare_Header(Big_A, 3, POSITIVE);
- LIMIT = Bignum_Top(Big_A);
- *LIMIT-- = *ARG1;
- *LIMIT-- = *(ARG1-1);
- *LIMIT = *(ARG1-2);
- Prepare_Header(Big_B, 2, POSITIVE);
- *Bignum_Top(Big_B) = dvsr1;
- *Bignum_Bottom(Big_B) = dvsr2;
- scale(Big_B, Big_B, guess);
- if ((*Bignum_Top(Big_B)) == 0) LEN(Big_B) -= 1;
- } while (big_compare_unsigned(Big_B, Big_A) == ONE_BIGGER);
-\f
- LIMIT = Bignum_Top(ARG2);
- PROD = Bignum_Bottom(ARG2);
- Digit = RADIX + *SCAN;
- while (LIMIT >= PROD)
- {
- Prod = *PROD++ * guess;
- Digit = Digit - Get_Digit(Prod);
- *SCAN++ = Get_Digit(Digit);
- Digit = ((*SCAN - Get_Carry(Prod)) +
- (MAX_DIGIT_SIZE +
- ((Digit < 0) ? -1 : Get_Carry(Digit))));
- }
- *SCAN++ = Get_Digit(Digit);
-
- if (Get_Carry(Digit) == 0)
- {
- /* Guess is one too big, add back. */
-
- Digit = 0;
- guess -= 1;
- LIMIT = Bignum_Top(ARG2);
- SCAN = SCAN - LEN(ARG2);
- PROD = Bignum_Bottom(ARG2);
- while (LIMIT >= PROD)
- {
- Digit = *SCAN + *PROD++ + Get_Carry(Digit);
- *SCAN++ = Get_Digit(Digit);
- }
- *SCAN = 0;
- }
- *QUOT_SCAN-- = guess;
- ARG1 -= 1;
- SCAN = ARG1 - LEN(ARG2);
- }
-}
-\f
-/* div_signed_bignum() differentiates between all the possible
- * cases and allocates storage for the quotient, remainder, and
- * any intrmediate storage needed.
- */
-
-Pointer
-div_signed_bignum(ARG1, ARG2)
- bigdigit *ARG1, *ARG2;
-{
- bigdigit *SARG2;
- bigdigit *QUOT, *REMD;
- Pointer *Cons_Cell;
-
- if (ZERO_BIGNUM(ARG2))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Primitive_GC_If_Needed(2);
- Cons_Cell = Free;
- Free += 2;
-
- if (big_compare_unsigned(ARG1, ARG2) == TWO_BIGGER)
- {
- /* Trivial Solution for ARG1 > ARG2
- * Quotient is zero and the remainder is just a copy of Arg_1.
- */
-
- Primitive_GC_If_Needed(Align(0)+Align(LEN(ARG1)));
- QUOT = BIGNUM(Free);
- Free += Align(0);
- Prepare_Header(QUOT, 0, POSITIVE);
- REMD = BIGNUM(Free);
- Free += Align(LEN(ARG1));
- copy_bignum(ARG1, REMD);
- }
- else if (LEN(ARG2)==1)
- {
- /* Divisor is only one digit long.
- * unscale() is used to divide out Arg_1 and the remainder is the
- * single digit returned by unscale(), coerced to a bignum.
- */
-
- Primitive_GC_If_Needed(Align(LEN(ARG1))+Align(1));
- QUOT = BIGNUM(Free);
- Free += Align(LEN(ARG1));
- REMD = BIGNUM(Free);
- Free += Align(1);
- Prepare_Header(QUOT, LEN(ARG1), POSITIVE);
- Prepare_Header(REMD, 1, POSITIVE);
- *(Bignum_Bottom(REMD)) =
- unscale(ARG1, QUOT, (long) *(Bignum_Bottom(ARG2)));
- trim_bignum(REMD);
- trim_bignum(QUOT);
- }
- else
-\f
- {
- /* Usual case. div_internal() is called. A normalized copy of Arg_1
- * resides in REMD, which ultimately becomes the remainder. The
- * normalized copy of Arg_2 is in SARG2.
- */
-
- bigdouble temp;
-
- temp = (Align(LEN(ARG1)-LEN(ARG2)+1) + Align(LEN(ARG1)+1)
- + Align(LEN(ARG2)+1));
- Primitive_GC_If_Needed(temp);
- QUOT = BIGNUM(Free);
- *Free = Make_Header(Align(LEN(ARG1)-LEN(ARG2)+1));
- Free += Align(LEN(ARG1)-LEN(ARG2)+1);
- REMD = BIGNUM(Free);
- *Free = Make_Header(Align(LEN(ARG1)+1));
- Free += Align(LEN(ARG1)+1);
- SARG2 = BIGNUM(Free);
- *Free = Make_Header(Align(LEN(ARG2)+1));
- Free += Align(LEN(ARG2)+1);
-
- temp = RADIX / (1 + *(Bignum_Top(ARG2)));
- scale(ARG1, REMD, temp);
- scale(ARG2, SARG2, temp);
- div_internal(REMD, SARG2, QUOT);
- unscale(REMD, REMD, temp);
- trim_bignum(REMD);
- trim_bignum(QUOT);
- }
-\f
-/* Determines sign of the quotient and remainder */
-
- SIGN(REMD) = POSITIVE;
- SIGN(QUOT) = POSITIVE;
- switch(Categorize_Sign(ARG1,ARG2))
- { case ARG2_NEGATIVE :
- SIGN(QUOT) = NEGATIVE;
- break;
- case ARG1_NEGATIVE :
- SIGN(QUOT) = NEGATIVE;
- case BOTH_NEGATIVE :
- SIGN(REMD) = NEGATIVE;
- break;
- case BOTH_POSITIVE : break;
- default : Sign_Error("divide_bignum()");
- }
- /* Glue the two results in a list and return as answer */
- Cons_Cell[CONS_CAR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) QUOT);
- Cons_Cell[CONS_CDR] = Make_Pointer(TC_BIG_FIXNUM, (Pointer *) REMD);
- return Make_Pointer(TC_LIST, Cons_Cell);
-}
-\f
-/* Utility for debugging */
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-void
-print_digits(name, num, how_many)
- char *name;
- bigdigit *num;
- int how_many;
-{
- int NDigits = LEN(num);
- int limit;
-
- printf("\n%s = 0x%08x", name, num);
- printf("\n Sign: %c, Vector length: %d, # Digits: %d",
- ((SIGN(num) == NEGATIVE) ? '-' :
- ((SIGN(num) == POSITIVE) ? '+' : '?')),
- Datum(((Pointer *) num)[VECTOR_LENGTH]),
- NDigits);
- if (how_many == -1)
- limit = NDigits;
- else
- limit = ((how_many < NDigits) ? how_many : NDigits);
- num = Bignum_Bottom(num);
- while (--how_many >= 0)
- printf("\n 0x%04x", *num++);
- if (limit < NDigits)
- printf("\n ...");
- printf("\n");
- return;
-}
-#endif
-\f
-/* Top level bignum primitives */
-/* Coercion primitives. */
-
-/* (COERCE-FIXNUM-TO-BIGNUM FIXNUM)
- Returns its argument if FIXNUM isn't a fixnum. Otherwise
- it returns the corresponding bignum.
-*/
-Built_In_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM", 0x67)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- return Fix_To_Big(Arg1);
-}
-
-/* (COERCE-BIGNUM-TO-FIXNUM BIGNUM)
- When given a bignum, returns the equivalent fixnum if there is
- one. If BIGNUM is out of range, or isn't a bignum, returns
- BIGNUM. */
-
-Built_In_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM", 0x68)
-{
- Primitive_1_Arg ();
-
- Arg_1_Type (TC_BIG_FIXNUM);
- return (Big_To_Fix (Arg1));
-}
-\f
-/* (LISTIFY-BIGNUM BIGNUM RADIX)
- Returns a list of numbers, in the range 0 through RADIX-1, which
- represent the BIGNUM in that radix.
-*/
-Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM", 0x50)
-{
- fast bigdigit *TOP1, *size;
- quick Pointer *RFree;
- fast bigdigit *ARG1;
- fast long pradix;
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- Set_Time_Zone(Zone_Math);
-
- ARG1 = BIGNUM(Get_Pointer(Arg1));
- size = &LEN(ARG1);
- if (*size == 0)
- {
- Primitive_GC_If_Needed(2);
- *Free++ = Make_Unsigned_Fixnum(0);
- *Free++ = NIL;
- return Make_Pointer(TC_LIST, Free-2);
- }
- Sign_Extend(Arg2, pradix);
- Primitive_GC_If_Needed(Find_Length(pradix, *size)+Align(*size));
- ARG1 = BIGNUM(Free);
- copy_bignum(BIGNUM(Get_Pointer(Arg1)), ARG1);
- Free += Align(*size);
- RFree = Free;
- size = &LEN(ARG1);
- TOP1 = Bignum_Top(ARG1);
- while (*size > 0)
- {
- *RFree++ = Make_Unsigned_Fixnum(unscale(ARG1, ARG1, pradix));
- *RFree = Make_Pointer(TC_LIST, RFree-3);
- RFree += 1;
- if (*TOP1 == 0)
- {
- *size -= 1;
- TOP1--;
- }
- }
- Free[CONS_CDR] = NIL;
- Free = RFree;
- return Make_Pointer(TC_LIST, RFree-2);
-}
-\f
-/* All the binary bignum primitives take two arguments and return NIL
- if either of them is not a bignum. If both arguments are bignums,
- the perform the operation and return the answer.
-*/
-
-#define Binary_Primitive(Op) \
-{ \
- Pointer Result, *Orig_Free; \
- Primitive_2_Args(); \
- \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Arg_2_Type(TC_BIG_FIXNUM); \
- Set_Time_Zone(Zone_Math); \
- Orig_Free = Free; \
- Result = Op(BIGNUM(Get_Pointer(Arg1)), BIGNUM(Get_Pointer(Arg2))); \
- if (Consistency_Check && (Get_Pointer(Result) != Orig_Free)) \
- { \
- fprintf(stderr, "\nBignum operation result at 0x%x, Free was 0x%x\n", \
- Address(Result), Free); \
- Microcode_Termination(TERM_EXIT); \
- } \
- Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
- if (Consistency_Check && (Free > Heap_Top)) \
- { \
- fprintf(stderr, "\nBignum operation result at 0x%x, length 0x%x\n", \
- Address(Result), Vector_Length(Result)); \
- Microcode_Termination(TERM_EXIT); \
- } \
- return Result; \
-}
-
-Built_In_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM", 0x4C)
-Binary_Primitive(plus_signed_bignum)
-
-Built_In_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM", 0x4D)
-Binary_Primitive(minus_signed_bignum)
-
-Built_In_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM", 0x4E)
-Binary_Primitive(multiply_signed_bignum)
-\f
-/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
- * returns a cons of the bignum quotient and remainder of both arguments.
- */
-
-Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM", 0x4F)
-{
- Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FIXNUM);
- Arg_2_Type(TC_BIG_FIXNUM);
- Set_Time_Zone(Zone_Math);
- Result = div_signed_bignum(BIGNUM(Get_Pointer(Arg1)),
- BIGNUM(Get_Pointer(Arg2)));
- if (Bignum_Debug)
- printf("\nResult=0x%x [%x %x]\n",
- Result, Fast_Vector_Ref(Result, 0), Fast_Vector_Ref(Result, 1));
- First = Get_Pointer(Fast_Vector_Ref(Result, CONS_CAR));
- Second = Get_Pointer(Fast_Vector_Ref(Result, CONS_CDR));
- if (Bignum_Debug)
- printf("\nFirst=0x%x [%x %x]; Second=0x%x [%x %x]\n",
- First, First[0], First[1], Second, Second[0], Second[1]);
- if (Consistency_Check)
- { if (First > Second)
- {
- fprintf(stderr, "\nBignum_Divide: results swapped.\n");
- Microcode_Termination(TERM_EXIT);
- }
- else if (First != Orig_Free+2)
- {
- fprintf(stderr, "\nBignum Divide: hole at start\n");
- Microcode_Termination(TERM_EXIT);
- }
- }
- End_Of_First = First + 1 + Get_Integer(First[0]);
- if (Bignum_Debug)
- printf("\nEnd_Of_First=0x%x\n", End_Of_First);
- if (End_Of_First != Second)
- {
- *End_Of_First =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1);
- if (Bignum_Debug)
- printf("\nGap=0x%x\n", (Second-End_Of_First)-1);
- }
- Free = Second + 1 + Get_Integer(Second[0]);
- if (Bignum_Debug)
- printf("\nEnd=0x%x\n", Free);
- return Result;
-}
-\f
-/* All the unary bignum predicates take one argument and return NIL if
- it is not a bignum. Otherwise, they return a fixnum 1 if the
- predicate is true or a fixnum 0 if it is false. This convention of
- NIL/0/1 is used for all numeric predicates so that the generic
- dispatch can detect "inapplicable" as distinct from "false" answer.
-*/
-
-#define Unary_Predicate(Test) \
-{ \
- bigdigit *ARG; \
- Primitive_1_Arg(); \
- \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Set_Time_Zone(Zone_Math); \
- ARG = BIGNUM(Get_Pointer(Arg1)); \
- return Make_Unsigned_Fixnum(((Test) ? 1 : 0)); \
-}
-
-Built_In_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?", 0x6F)
-Unary_Predicate(LEN(ARG) == 0)
-
-Built_In_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?", 0x53)
-Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG))
-
-Built_In_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?", 0x80)
-Unary_Predicate((LEN(ARG) != 0) && NEG_BIGNUM(ARG))
-
-/* All the binary bignum predicates take two arguments and return NIL
- if either of them is not a bignum. Otherwise, they return an
- answer as described above for the unary predicates.
-*/
-\f
-#define Binary_Predicate(Code) \
-{ \
- int result; \
- Primitive_2_Args(); \
- \
- Arg_1_Type(TC_BIG_FIXNUM); \
- Arg_2_Type(TC_BIG_FIXNUM); \
- Set_Time_Zone(Zone_Math); \
- if (big_compare(BIGNUM(Get_Pointer(Arg1)), \
- BIGNUM(Get_Pointer(Arg2))) == Code) \
- result = 1; \
- else \
- result = 0; \
- return Make_Unsigned_Fixnum(result); \
-}
-
-Built_In_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?", 0x51)
-Binary_Predicate(EQUAL)
-
-Built_In_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?", 0x82)
-Binary_Predicate(ONE_BIGGER)
-
-Built_In_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?", 0x52)
-Binary_Predicate(TWO_BIGGER)
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.h,v 9.23 1987/04/11 15:17:09 jinx Rel $
-
- Head file for bignums. This is shared by bignum.c and generic.c.
-*/
-\f
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Debug_Test(Res) \
-{ Pointer R = Make_Pointer(TC_BIG_FIXNUM, Res); \
- if (Nth_Vector_Loc(R, Vector_Length(R)) != (Free-1)) \
- { printf("\nResult=%x -> %x %x %x, Length=%d, Free=%x\n", \
- R, Fast_Vector_Ref(R, 0), \
- Fast_Vector_Ref(R, 1), Fast_Vector_Ref(R, 2), \
- Vector_Length(R), Free); \
- Microcode_Termination(TERM_EXIT); \
- } \
-}
-#else
-#define Debug_Test(Res) { }
-#endif
-\f
-#define POSITIVE 1
-#define NEGATIVE 0
-
-/* The representation of a BIGNUM is machine dependent. For a VAX-11
- * it is as follows:
- */
-
-#ifdef pdp10
-typedef unsigned int bigdigit;
-typedef long bigdouble;
-#define SHIFT 16
-#define factor 1
-#else
-#if ((USHORT_SIZE * 2) <= ULONG_SIZE)
-#define bigdigit unsigned short
-#define bigdouble long /* Should be unsigned */
-#define SHIFT USHORT_SIZE
-#define factor (sizeof(Pointer)/sizeof(bigdigit))
-#else
-#if ((CHAR_SIZE * 2) <= ULONG_SIZE)
-#define bigdigit unsigned char
-#define bigdouble long /* Should be unsigned */
-#define SHIFT CHAR_SIZE
-#define factor (sizeof(Pointer)/sizeof(bigdigit))
-#else
-#include "Cannot compile bignums. All types too large. See bignum.h"
-#endif
-#endif
-#endif
-
-#define DELTA \
- ((sizeof(bigdouble)-sizeof(bigdigit))*CHAR_SIZE)
-#define SIGN(Bignum) (Bignum[factor])
-#define LEN(Bignum) (Bignum[factor+1])
-#define Bignum_Bottom(Bignum) (&(Bignum)[factor+2])
-#define Bignum_Top(Bignum) (&(Bignum)[factor+1+LEN(Bignum)])
-#define Align(ndigits) ((((ndigits) + factor + 1) / factor) + 1)
-
-/* For temporary bignums */
-
-#define TEMP_SIZE Align(4)
-
-/* Macros for making BIGNUM headers */
-
-#define Make_Header(l) Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,(l-1))
-#define Prepare_Header(Bignum,Length,Sign) \
- { *((Pointer *) Bignum) = Make_Header(Align(Length)); \
- SIGN(Bignum) = Sign; \
- LEN(Bignum) = Length; \
- }
-\f
-/* Predicates coded as macros for determining the sign of BIGNUM's */
-
-#define POS_BIGNUM(Bignum) (SIGN(Bignum) == POSITIVE)
-#define NEG_BIGNUM(Bignum) (SIGN(Bignum) == NEGATIVE)
-#define ZERO_BIGNUM(Bignum) (LEN(Bignum) == 0)
-#define NON_ZERO_BIGNUM(Bignum) (LEN(Bignum) != 0)
-
-
-/* Coerces a C pointer to point to BIGNUM digits */
-
-#define BIGNUM(ptr) ((bigdigit *) ptr)
-
-/* Macros for manipulating long BIGNUM digits */
-
-#define RADIX (1<<SHIFT)
-#define MAX_DIGIT_SIZE (RADIX-1)
-#define CARRY_MASK (MAX_DIGIT_SIZE<<SHIFT)
-#define DIGIT_MASK MAX_DIGIT_SIZE
-#define DIV_MASK ((1<<DELTA)-1)
-#define Get_Carry(lw) (((lw & CARRY_MASK) >> SHIFT) & DIGIT_MASK)
-#define Get_Digit(lw) (lw & DIGIT_MASK)
-#define Mul_Radix(sw) (sw << SHIFT)
-#define Div_Radix(lw) ((lw >> SHIFT) & DIV_MASK)
-#define Rem_Radix(lw) (lw & DIGIT_MASK)
-
-/* Length of the BIGNUM that contains the largest FIXNUM */
-
-#define FIXNUM_LENGTH_AS_BIGNUM ((FIXNUM_LENGTH + (SHIFT - 1)) / SHIFT)
-#define C_INTEGER_LENGTH_AS_BIGNUM ((POINTER_LENGTH + (SHIFT - 1)) / SHIFT)
-\f
-/* Cases returned by the comparison function big_compare() */
-
-#define EQUAL 0
-#define ONE_BIGGER 1
-#define TWO_BIGGER 2
-
-/* Categorize_Sign() takes two bignum's and classify them according
- * to four possible cases, depending on each's sign. Depends on
- * definition of POSITIVE and NEGATIVE, earlier!!!
- */
-
-#define Categorize_Sign(ARG1, ARG2) ((SIGN(ARG1) << 1) | SIGN(ARG2))
-#define BOTH_NEGATIVE 0
-#define ARG1_NEGATIVE 1
-#define ARG2_NEGATIVE 2
-#define BOTH_POSITIVE 3
-#define Sign_Error(proc) \
- { printf(proc); \
- printf(" -- Sign Determination Error\n"); \
- printf("Possibly Uncanonicalized Bignum\n"); \
- return ERR_UNDEFINED_PRIMITIVE; \
- }
-
-#define Fetch_Bignum(big) BIGNUM(Get_Pointer(big))
-
-#define Bignum_Operation(Object, Result) \
- Result = (Object); \
- Free = Nth_Vector_Loc(Result, Vector_Length(Result)+1); \
- Result = Big_To_Fix(Result);
-\f
-#define Divide_Bignum_Operation(Object, Result) \
-{ Pointer *End_Of_First, *First, *Second; \
- Result = (Object); \
- First = Get_Pointer(Vector_Ref(Result, CONS_CAR)); \
- Second = Get_Pointer(Vector_Ref(Result, CONS_CDR)); \
- End_Of_First = First+1+Get_Integer(First[0]); \
- if (End_Of_First != Second) \
- { *End_Of_First = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Second-End_Of_First)-1); \
- if (Bignum_Debug) printf("\nGap=0x%x\n", (Second-End_Of_First)-1); \
- } \
- Free = Second+1+Get_Integer(Second[0]); \
- Vector_Set(Result,CONS_CAR,Big_To_Fix(Vector_Ref(Result,CONS_CAR))); \
- Vector_Set(Result,CONS_CDR,Big_To_Fix(Vector_Ref(Result,CONS_CDR))); \
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $
- *
- * This File contains the code to translate internal format binary
- * files to portable format.
- *
- */
-\f
-/* Cheap renames */
-
-#define Internal_File Input_File
-#define Portable_File Output_File
-
-#include "translate.h"
-#include "trap.h"
-
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static long NFlonums, NIntegers, NStrings;
-static long NBits, NChars;
-static Pointer *Free_Objects, *Free_Cobjects;
-
-Load_Data(Count, To_Where)
-long Count;
-char *To_Where;
-{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
-}
-
-#define Reloc_or_Load_Debug false
-
-#include "load.c"
-\f
-/* Utility macros and procedures
- Pointer Objects handled specially in the portable format.
-*/
-
-#ifndef isalpha
-/* Just in case the stdio library atypically contains the character
- macros, just like the C book claims. */
-#include <ctype.h>
-#endif
-
-#ifndef ispunct
-/* This is in some libraries but not others */
-static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
-
-Boolean ispunct(c)
-fast char c;
-{ fast char *s = &punctuation[0];
- while (*s != '\0') if (*s++ == c) return true;
- return false;
-}
-#endif
-
-#define OUT(s) \
-fprintf(Portable_File, s); \
-break
-
-void
-print_a_char(c, name)
- fast char c;
- char *name;
-{
- switch(c)
- { case '\n': OUT("\\n");
- case '\t': OUT("\\t");
- case '\b': OUT("\\b");
- case '\r': OUT("\\r");
- case '\f': OUT("\\f");
- case '\\': OUT("\\\\");
- case '\0': OUT("\\0");
- case ' ' : OUT(" ");
- default:
- if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
- putc(c, Portable_File);
- else
- { fprintf(stderr,
- "%s: %s: File may not be portable: c = 0x%x\n",
- Program_Name, name, ((int) c));
- /* This does not follow C conventions, but eliminates ambiguity */
- fprintf(Portable_File, "\X%x ", ((int) c));
- }
- }
-}
-\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ \
- Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { \
- fast long i; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += pointer_to_char(i-1); \
- while(--i >= 0) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
-
-void
-print_a_string(from)
- Pointer *from;
-{ fast long len;
- fast char *string;
- long maxlen;
-
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
- if (Shuffle_Bytes)
- { while(len > 0)
- {
- print_a_char(string[3], "print_a_string");
- if (len > 1)
- print_a_char(string[2], "print_a_string");
- if (len > 2)
- print_a_char(string[1], "print_a_string");
- if (len > 3)
- print_a_char(string[0], "print_a_string");
- len -= 4;
- string += 4;
- }
- }
- else while(--len >= 0) print_a_char(*string++, "print_a_string");
- putc('\n', Portable_File);
- return;
-}
-\f
-void
-print_a_fixnum(val)
- long val;
-{
- fast long size_in_bits;
- fast unsigned long temp;
-
- temp = ((val < 0) ? -val : val);
- for (size_in_bits = 0; temp != 0; size_in_bits += 1)
- temp = temp >> 1;
- fprintf(Portable_File, "%02x %c ",
- TC_FIXNUM,
- (val < 0 ? '-' : '+'));
- if (val == 0)
- fprintf(Portable_File, "0\n");
- else
- {
- fprintf(Portable_File, "%ld ", size_in_bits);
- temp = ((val < 0) ? -val : val);
- while (temp != 0)
- { fprintf(Portable_File, "%01lx", (temp % 16));
- temp = temp >> 4;
- }
- fprintf(Portable_File, "\n");
- }
- return;
-}
-\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
-
-void
-print_a_bignum(from)
- Pointer *from;
-{
- fast bigdigit *the_number, *the_top;
- fast long size_in_bits;
- fast unsigned long temp; /* Potential signed problems */
-
- the_number = BIGNUM(from);
- temp = LEN(the_number);
- if (temp == 0)
- fprintf(Portable_File, "%02x + 0\n",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
- else
- { fast long tail;
- for (size_in_bits = ((temp - 1) * SHIFT),
- temp = ((long) (*Bignum_Top(the_number)));
- temp != 0;
- size_in_bits += 1)
- temp = temp >> 1;
-
- fprintf(Portable_File, "%02x %c %ld ",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
- (NEG_BIGNUM(the_number) ? '-' : '+'),
- size_in_bits);
- tail = size_in_bits % SHIFT;
- if (tail == 0) tail = SHIFT;
- temp = 0;
- size_in_bits = 0;
- the_top = Bignum_Top(the_number);
- for(the_number = Bignum_Bottom(the_number);
- the_number <= the_top;
- the_number += 1)
- { temp |= (((unsigned long) (*the_number)) << size_in_bits);
- for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
- size_in_bits > 3;
- size_in_bits -= 4)
- { fprintf(Portable_File, "%01lx", temp % 16);
- temp = temp >> 4;
- }
- }
- if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
- else fprintf(Portable_File, "\n");
- }
- return;
-}
-\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
-}
-
-print_a_flonum(val)
-double val;
-{ fast long size_in_bits;
- fast double mant, temp;
- int expt;
- extern double frexp();
-
- fprintf(Portable_File, "%02x %c ",
- TC_BIG_FLONUM,
- ((val < 0.0) ? '-' : '+'));
- if (val == 0.0)
- { fprintf(Portable_File, "0\n");
- return;
- }
- mant = frexp(((val < 0.0) ? -val : val), &expt);
- size_in_bits = 1;
- for(temp = ((mant * 2.0) - 1.0);
- temp != 0;
- size_in_bits += 1)
- { temp *= 2.0;
- if (temp >= 1.0) temp -= 1.0;
- }
- fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
- for (size_in_bits = hex_digits(size_in_bits);
- size_in_bits > 0;
- size_in_bits -= 1)
- { fast unsigned int digit = 0;
- for (expt = 4; --expt >= 0;)
- { mant *= 2.0;
- digit = digit << 1;
- if (mant >= 1.0)
- { mant -= 1.0;
- digit += 1;
- }
- }
- fprintf(Portable_File, "%01x", digit);
- }
- fprintf(Portable_File, "\n");
- return;
-}
-\f
-/* Normal Objects */
-
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
-}
-
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
-}
-
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
-}
-
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { fast long len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
- } \
-}
-\f
-/* Common Pointer Code */
-
-#define Do_Pointer(Scn, Action) \
-Old_Address = Get_Pointer(This); \
-if (Datum(This) < Const_Base) \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects) \
-else if (Datum(This) < Dumped_Constant_Top) \
-Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects) \
-else \
-{ fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- exit(1); \
-} \
-(Scn) += 1; \
-break
-\f
-/* Processing of a single area */
-
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area(Code, &Area, &Bound, &Obj, &FObj)
-
-Process_Area(Code, Area, Bound, Obj, FObj)
-int Code;
-fast long *Area, *Bound;
-fast long *Obj;
-fast Pointer **FObj;
-{ fast Pointer This, *Old_Address, Old_Contents;
- while(*Area != *Bound)
- { This = Mem_Base[*Area];
- Switch_by_GC_Type(This)
- { case TC_MANIFEST_NM_VECTOR:
- if (Null_NMV)
- { fast int i = Get_Integer(This);
- *Area += 1;
- for ( ; --i >= 0; *Area += 1)
- Mem_Base[*Area] = NIL;
- break;
- }
- /* else, Unknown object! */
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *Area += 1 + Get_Integer(This);
- break;
-
- case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (Get_Integer(This) != 0)
- { fprintf(stderr, "%s: Broken Heart found in scan.\n",
- Program_Name);
- exit(1);
- }
- *Area += 1;
- break;
-
- case_compiled_entry_point:
- fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
- Program_Name);
- exit(1);
-\f
- case TC_FIXNUM:
- NIntegers += 1;
- NBits += fixnum_to_bits;
- /* Fall Through */
- case TC_CHARACTER:
- Process_Character:
- Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
- *Obj += 1;
- **FObj = This;
- *FObj += 1;
- /* Fall through */
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case TC_PRIMITIVE_EXTERNAL:
- case_simple_Non_Pointer:
- *Area += 1;
- break;
-
- case_Cell:
- Do_Pointer(*Area, Do_Cell);
-
- case TC_REFERENCE_TRAP:
- {
- long kind;
-
- kind = Datum(This);
-
- if (upgrade_traps)
- {
- /* It is an old UNASSIGNED object. */
- if (kind == 0)
- {
- Mem_Base[*Area] = UNASSIGNED_OBJECT;
- *Area += 1;
- break;
- }
- if (kind == 1)
- {
- Mem_Base[*Area] = UNBOUND_OBJECT;
- *Area += 1;
- break;
- }
- fprintf(stderr,
- "%s: Bad old unassigned object. 0x%x.\n",
- Program_Name, This);
- exit(1);
- }
- if (kind <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
-
- *Area += 1;
- break;
- }
- }
- /* Fall through */
-\f
- case TC_WEAK_CONS:
- case_Pair:
- Do_Pointer(*Area, Do_Pair);
-
- case TC_VARIABLE:
- case_Triple:
- Do_Pointer(*Area, Do_Triple);
-
- case TC_BIG_FLONUM:
- Do_Pointer(*Area, Do_Flonum);
-
- case TC_BIG_FIXNUM:
- Do_Pointer(*Area, Do_Bignum);
-
- case TC_CHARACTER_STRING:
- Do_Pointer(*Area, Do_String);
-
- case TC_ENVIRONMENT:
- if (upgrade_traps)
- {
- fprintf(stderr,
- "%s: Cannot upgrade environments.\n",
- Program_Name);
- exit(1);
- }
- /* Fall through */
- case TC_FUTURE:
- case_simple_Vector:
- Do_Pointer(*Area, Do_Vector);
-
- default:
- Bad_Type:
- fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- Program_Name, Type_Code(This));
- exit(1);
- }
- }
-}
-\f
-/* Output macros */
-
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
-
-#define print_external_object(from) \
-{ switch(Type_Code(*from)) \
- { case TC_FIXNUM: \
- { long Value; \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- case TC_BIG_FIXNUM: \
- from += 1; \
- print_a_bignum(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_CHARACTER_STRING: \
- from += 1; \
- print_a_string(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_BIG_FLONUM: \
- print_a_flonum(*((double *) (from+1))); \
- from += 1 + float_to_pointer; \
- break; \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- exit(1); \
- } \
-}
-\f
-/* Debugging Aids and Consistency Checks */
-
-#ifdef DEBUG
-
-When(what, message)
-Boolean what;
-char *message;
-{ if (what)
- { fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
- exit(1);
- }
- return;
-}
-
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj)); \
-fprintf(stderr, "%s: ", (name)); \
-fprintf(stderr, (format), (obj))
-
-#else
-
-#define When(what, message)
-
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj))
-
-#endif
-\f
-/* The main program */
-
-do_it()
-{ Pointer *Heap;
- long Initial_Free;
-
- /* Load the Data */
-
- if (!Read_Header())
- { fprintf(stderr,
- "%s: Input file does not appear to be in FASL format.\n",
- Program_Name);
- exit(1);
- }
-
- if ((Version != FASL_FORMAT_VERSION) ||
- (Sub_Version > FASL_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUPPORTED) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
- { fprintf(stderr, "%s:\n", Program_Name);
- fprintf(stderr,
- "FASL File Version %ld Subversion %ld Machine Type %ld\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- "Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- exit(1);
- }
-
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- Shuffle_Bytes = false;
- upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
-
- /* Constant Space not currently supported */
-
- if (Const_Count != 0)
- { fprintf(stderr,
- "%s: Input file has a constant space area.\n",
- Program_Name);
- exit(1);
- }
-
- { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
- Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
- if (Heap == NULL)
- { fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
- exit(1);
- }
- }
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
- Load_Data(Heap_Count, &Heap[0]);
- Load_Data(Const_Count, &Heap[Heap_Count]);
- Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
- Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
- fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
- fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
- fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
- fprintf(stderr, "Constant Count = %6d\n", Const_Count);
-#endif
-\f
- /* Reformat the data */
-
- NFlonums = NIntegers = NStrings = NBits = NChars = 0;
- Mem_Base = &Heap[Heap_Count + Const_Count];
- if (Ext_Prim_Vector == NIL)
- { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Mem_Base[2] = NIL;
- Initial_Free = NROOTS + 1;
- Scan = 1;
- }
- else
- { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Initial_Free = NROOTS;
- Scan = 0;
- }
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
- Objects = 0;
-
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
- Constant_Objects = 0;
-
-#if true
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
-#else
- /* When Constant Space finally becomes supported,
- something like this must be done. */
- while (true)
- { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant,
- Free_Constant, Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
- if (Scan == Free) break;
- }
-#endif
-\f
- /* Consistency checks */
-
- When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
- "Free_Objects overran Heap Object Space");
- When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
- "Free_Constant overran Constant Space");
- When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
- Const_Count),
- "Free_Cobjects overran Constant Object Space");
-\f
- /* Output the data */
-
- /* Header */
-
- print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
- print_header("Flags", Make_Flags(), "%ld\n");
- print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
- print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
- print_header("Heap Count", (Free - NROOTS), "%ld\n");
- print_header("Heap Base", NROOTS, "%ld\n");
- print_header("Heap Objects", Objects, "%ld\n");
-
- /* Currently Constant and Pure not supported, but the header is ready */
-
- print_header("Pure Count", 0, "%ld\n");
- print_header("Pure Base", Free_Constant, "%ld\n");
- print_header("Pure Objects", 0, "%ld\n");
- print_header("Constant Count", 0, "%ld\n");
- print_header("Constant Base", Free_Constant, "%ld\n");
- print_header("Constant Objects", 0, "%ld\n");
-
- print_header("Number of flonums", NFlonums, "%ld\n");
- print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of strings", NStrings, "%ld\n");
- print_header("Number of bits in integers", NBits, "%ld\n");
- print_header("Number of characters in strings", NChars, "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
-\f
- /* External Objects */
-
- /* Heap External Objects */
-
- Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
- for (; Objects > 0; Objects -= 1)
- print_external_object(Free_Objects);
-
-#if false
- /* Pure External Objects */
-
- Free_Cobjects = &Mem_Base[Pure_Objects_Start];
- for (; Pure_Objects > 0; Pure_Objects -= 1)
- print_external_object(Free_Cobjects);
-
- /* Constant External Objects */
-
- Free_Cobjects = &Mem_Base[Constant_Objects_Start];
- for (; Constant_Objects > 0; Constant_Objects -= 1)
- print_external_object(Free_Cobjects);
-
-#endif
-\f
- /* Pointer Objects */
-
- /* Heap Objects */
-
- Free_Cobjects = &Mem_Base[Free];
- for (Free_Objects = &Mem_Base[NROOTS];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-
-#if false
- /* Pure Objects */
-
- Free_Cobjects = &Mem_Base[Free_Pure];
- for (Free_Objects = &Mem_Base[Pure_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-
- /* Constant Objects */
-
- Free_Cobjects = &Mem_Base[Free_Constant];
- for (Free_Objects = &Mem_Base[Constant_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-#endif
-
- return;
-}
-\f
-/* Top Level */
-
-static int Noptions = 3;
-
-static struct Option_Struct Options[] =
- {{"Do_Not_Compact", false, &Compact_P},
- {"Null_Out_NMVs", true, &Null_NMV},
- {"Swap_Bytes", true, &Shuffle_Bytes}};
-
-main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.25 1987/04/17 03:50:09 cph Exp $
-
- Bit string primitives.
-
-*/
-\f
-/*
-
-Memory layout of bit strings:
-
-+-------+-------+-------+-------+
-| NMV | GC size (longwords) | 0
-+-------+-------+-------+-------+
-| Size in bits | 1
-+-------+-------+-------+-------+
-|MSB | 2
-+-------+-------+-------+-------+
-| | 3
-+-------+-------+-------+-------+
-. . .
-. . .
-. . .
-+-------+-------+-------+-------+
-| LSB| N
-+-------+-------+-------+-------+
-
-The first data word (marked as word "2" above) is where any excess
-bits are kept.
-
-The "size in bits" is a C "long" integer.
-
-Conversions between nonnegative integers and bit strings are
-implemented here; they use the standard binary encoding, in which
-each index selects the bit corresponding to that power of 2. Thus
-bit 0 is the LSB.
-
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-#include "bignum.h"
-
-#define bits_to_pointers( bits) \
-(((bits) + (POINTER_LENGTH - 1)) / POINTER_LENGTH)
-
-#define bit_string_length( bit_string) \
-(Fast_Vector_Ref( bit_string, NM_ENTRY_COUNT))
-
-#define bit_string_start_ptr( bit_string) \
-(Nth_Vector_Loc( bit_string, NM_DATA))
-
-#define bit_string_end_ptr( bit_string) \
-(Nth_Vector_Loc( bit_string, (Vector_Length( bit_string) + 1)))
-
-#define any_mask( nbits, offset) (low_mask( nbits) << (offset))
-#define low_mask( nbits) ((1 << (nbits)) - 1)
-\f
-Pointer
-allocate_bit_string( length)
- long length;
-{
- long total_pointers;
- Pointer result;
-
- total_pointers = (NM_HEADER_LENGTH + bits_to_pointers( length));
- Primitive_GC_If_Needed( total_pointers);
- Free[NM_VECTOR_HEADER] =
- Make_Non_Pointer( TC_MANIFEST_NM_VECTOR, (total_pointers - 1));
- Free[NM_ENTRY_COUNT] = length;
- result = Make_Pointer( TC_BIT_STRING, Free);
- Free += total_pointers;
- return result;
-}
-
-/* (BIT-STRING-ALLOCATE length)
- Returns an uninitialized bit string of the given length. */
-
-Built_In_Primitive( Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1)
-{
- Primitive_1_Arg();
-
- Arg_1_Type( TC_FIXNUM);
- return allocate_bit_string( Get_Integer( Arg1));
-}
-
-/* (BIT-STRING? object)
- Returns true iff object is a bit string. */
-
-Built_In_Primitive( Prim_bit_string_p, 1, "BIT-STRING?", 0xD3)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive( Arg1, Arg1);
- return ((Type_Code( Arg1) == TC_BIT_STRING) ? TRUTH : NIL);
-}
-\f
-void
-fill_bit_string( bit_string, sense)
- Pointer bit_string;
- Boolean sense;
-{
- Pointer *scanner;
- Pointer filler;
- long i;
-
- filler = ((Pointer) (sense ? -1 : 0));
- scanner = bit_string_start_ptr( bit_string);
- for (i = bits_to_pointers( bit_string_length( bit_string));
- (i > 0); i -= 1)
- *scanner++ = filler;
-}
-
-void
-clear_bit_string( bit_string)
- Pointer bit_string;
-{
- Pointer *scanner;
- long i;
-
- scanner = bit_string_start_ptr( bit_string);
- for (i = bits_to_pointers( bit_string_length( bit_string));
- (i > 0); i -= 1)
- *scanner++ = 0;
-}
-\f
-/* (MAKE-BIT-STRING size initialization)
- Returns a bit string of the specified size with all the bits
- set to zero if the initialization is false, one otherwise. */
-
-Built_In_Primitive( Prim_make_bit_string, 2, "MAKE-BIT-STRING", 0xD2)
-{
- Pointer result;
- Primitive_2_Args();
-
- Arg_1_Type( TC_FIXNUM);
- result = allocate_bit_string( Get_Integer( Arg1));
- fill_bit_string( result, (Arg2 != NIL));
- return result;
-}
-
-/* (BIT-STRING-FILL! bit-string initialization)
- Fills the bit string with zeros if the initialization is false,
- otherwise fills it with ones. */
-
-Built_In_Primitive( Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!", 0x197)
-{
- Primitive_2_Args();
-
- Arg_1_Type( TC_BIT_STRING);
- fill_bit_string( Arg1, (Arg2 != NIL));
- return NIL;
-}
-
-/* (BIT-STRING-LENGTH bit-string)
- Returns the number of bits in BIT-STRING. */
-
-Built_In_Primitive(Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4)
-{
- Primitive_1_Arg();
-
- Arg_1_Type( TC_BIT_STRING);
- return Make_Non_Pointer( TC_FIXNUM, bit_string_length( Arg1));
-}
-\f
-/* The computation of the variable `word' is especially clever. To
- understand it, note that the index of the last pointer of a vector is
- also the GC length of the vector, so that all we need do is subtract
- the zero-based word index from the GC length. */
-
-#define index_check( To_Where, P, Low, High, Error) \
-{ \
- To_Where = Get_Integer( P); \
- if ((To_Where < (Low)) || (To_Where >= (High))) \
- Primitive_Error( Error) \
-}
-
-#define index_to_word( bit_string, index) \
-(Vector_Length( bit_string) - (index / POINTER_LENGTH))
-
-#define ref_initialization() \
-long index, word, mask; \
-Primitive_2_Args(); \
- \
-Arg_1_Type( TC_BIT_STRING); \
-Arg_2_Type( TC_FIXNUM); \
-index_check( index, Arg2, 0, bit_string_length( Arg1), \
- ERR_ARG_2_BAD_RANGE); \
- \
-word = index_to_word( Arg1, index); \
-mask = (1 << (index % POINTER_LENGTH));
-\f
-/* (BIT-STRING-REF bit-string index)
- Returns the boolean value of the indexed bit. */
-
-Built_In_Primitive( Prim_bit_string_ref, 2, "BIT-STRING-REF", 0xD5)
-{
- ref_initialization();
-
- if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
- return NIL;
- else
- return TRUTH;
-}
-
-/* (BIT-STRING-CLEAR! bit-string index)
- Sets the indexed bit to zero, returning its previous value
- as a boolean. */
-
-Built_In_Primitive( Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!", 0xD8)
-{
- ref_initialization();
-
- if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
- return NIL;
- else
- {
- Fast_Vector_Ref( Arg1, word) &= ~mask;
- return TRUTH;
- }
-}
-
-/* (BIT-STRING-SET! bit-string index)
- Sets the indexed bit to one, returning its previous value
- as a boolean. */
-
-Built_In_Primitive( Prim_bit_string_set_x, 2, "BIT-STRING-SET!", 0xD7)
-{
- ref_initialization();
-
- if ((Fast_Vector_Ref( Arg1, word) & mask) == 0)
- {
- Fast_Vector_Ref( Arg1, word) |= mask;
- return NIL;
- }
- else
- return TRUTH;
-}
-\f
-#define zero_section_p( start) \
-{ \
- long i; \
- Pointer *scan; \
- \
- scan = Nth_Vector_Loc( Arg1, (start)); \
- for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if (*scan++ != 0) \
- return NIL; \
- return TRUTH; \
-}
-
-/* (BIT-STRING-ZERO? bit-string)
- Returns true the argument has no "set" bits. */
-
-Built_In_Primitive( Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?", 0xD9)
-{
- long length, odd_bits;
- Primitive_1_Args();
-
- Arg_1_Type(TC_BIT_STRING);
-
- length = bit_string_length( Arg1);
- odd_bits = (length % POINTER_LENGTH);
- if (odd_bits == 0)
- zero_section_p( NM_DATA)
- else if ((Fast_Vector_Ref( Arg1, NM_DATA) & low_mask( odd_bits)) != 0)
- return NIL;
- else
- zero_section_p( NM_DATA + 1)
-}
-\f
-#define equal_sections_p( start) \
-{ \
- long i; \
- Pointer *scan1, *scan2; \
- \
- scan1 = Nth_Vector_Loc( Arg1, (start)); \
- scan2 = Nth_Vector_Loc( Arg2, (start)); \
- for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if (*scan1++ != *scan2++) \
- return NIL; \
- return TRUTH; \
-}
-
-/* (BIT-STRING=? bit-string-1 bit-string-2)
- Returns true iff the two bit strings contain the same bits. */
-
-Built_In_Primitive( Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D)
-{
- long length;
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIT_STRING);
- Arg_2_Type(TC_BIT_STRING);
-
- length = bit_string_length( Arg1);
- if (length != bit_string_length( Arg2))
- return NIL;
- else
- {
- long odd_bits;
-
- odd_bits = (length % POINTER_LENGTH);
- if (odd_bits == 0)
- equal_sections_p( NM_DATA)
- else
- {
- long mask;
-
- mask = low_mask( odd_bits);
- if ((Fast_Vector_Ref( Arg1, NM_DATA) & mask)
- != (Fast_Vector_Ref( Arg2, NM_DATA) & mask))
- return NIL;
- else
- equal_sections_p( NM_DATA + 1)
- }
- }
-}
-\f
-#define bitwise_op( action) \
-{ \
- Primitive_2_Args(); \
- \
- if (bit_string_length( Arg1) != bit_string_length( Arg2)) \
- Primitive_Error( ERR_ARG_1_BAD_RANGE) \
- else \
- { \
- long i; \
- Pointer *scan1, *scan2; \
- \
- scan1 = bit_string_start_ptr( Arg1); \
- scan2 = bit_string_start_ptr( Arg2); \
- for (i = (Vector_Length( Arg1) - 1); (i > 0); i -= 1) \
- *scan1++ action() (*scan2++); \
- } \
- return (NIL); \
-}
-
-#define bit_string_move_x_action() =
-#define bit_string_movec_x_action() = ~
-#define bit_string_or_x_action() |=
-#define bit_string_and_x_action() &=
-#define bit_string_andc_x_action() &= ~
-
-Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!", 0x198)
- bitwise_op( bit_string_move_x_action)
-
-Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!", 0x199)
- bitwise_op( bit_string_movec_x_action)
-
-Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!", 0x19A)
- bitwise_op( bit_string_or_x_action)
-
-Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!", 0x19B)
- bitwise_op( bit_string_and_x_action)
-
-Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!", 0x19C)
- bitwise_op( bit_string_andc_x_action)
-\f
-/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
- Destructively copies the substring of SOURCE between START1 and
- END1 into DESTINATION at START2. The copying is done from the
- MSB to the LSB (which only matters when SOURCE and DESTINATION
- are the same). */
-
-Built_In_Primitive( Prim_bit_substring_move_right_x, 5,
- "BIT-SUBSTRING-MOVE-RIGHT!", 0xD6)
-{
- long start1, end1, start2, end2, nbits;
- long end1_mod, end2_mod;
- void copy_bits();
- Primitive_5_Args();
-
- Arg_1_Type( TC_BIT_STRING);
- Arg_2_Type( TC_FIXNUM);
- Arg_3_Type( TC_FIXNUM);
- Arg_4_Type( TC_BIT_STRING);
- Arg_5_Type( TC_FIXNUM);
-
- start1 = Get_Integer( Arg2);
- end1 = Get_Integer( Arg3);
- start2 = Get_Integer( Arg5);
- nbits = (end1 - start1);
- end2 = (start2 + nbits);
-
- if ((start1 < 0) || (start1 > end1))
- Primitive_Error( ERR_ARG_2_BAD_RANGE);
- if (end1 > bit_string_length( Arg1))
- Primitive_Error( ERR_ARG_3_BAD_RANGE);
- if ((start2 < 0) || (end2 > bit_string_length( Arg4)))
- Primitive_Error( ERR_ARG_5_BAD_RANGE);
-
- end1_mod = (end1 % POINTER_LENGTH);
- end2_mod = (end2 % POINTER_LENGTH);
-
- /* Using `index_to_word' here with -1 offset will work in every
- case except when the `end' is 0. In this case the result of
- the expression `(-1 / POINTER_LENGTH)' is either 0 or -1, at
- the discretion of the C compiler being used. This doesn't
- matter because if `end' is zero, then no bits will be moved. */
-
- copy_bits( Nth_Vector_Loc( Arg1, index_to_word( Arg1, (end1 - 1))),
- ((end1_mod == 0) ? 0 : (POINTER_LENGTH - end1_mod)),
- Nth_Vector_Loc( Arg4, index_to_word( Arg4, (end2 - 1))),
- ((end2_mod == 0) ? 0 : (POINTER_LENGTH - end2_mod)),
- nbits);
- return (NIL);
-}
-\f
-#define masked_transfer( source, destination, nbits, offset) \
-{ \
- long mask; \
- \
- mask = any_mask( nbits, offset); \
- *destination = ((*source & mask) | (*destination & ~mask)); \
-}
-
-/* This procedure copies bits from one place to another.
- The offsets are measured from the MSB of the first Pointer of
- each of the arguments SOURCE and DESTINATION. It copies the bits
- starting with the MSB of a bit string and moving down. */
-
-void
-copy_bits( source, source_offset, destination, destination_offset, nbits)
- Pointer *source, *destination;
- long source_offset, destination_offset, nbits;
-{
-
- /* This common case can be done very quickly, by splitting the
- bit string into three parts. Since the source and destination are
- aligned relative to one another, the main body of bits can be
- transferred as Pointers, and only the `head' and `tail' need be
- treated specially. */
-
- if (source_offset == destination_offset)
- {
- if (source_offset != 0)
- {
- long head;
-
- head = (POINTER_LENGTH - source_offset);
- if (nbits <= head)
- {
- masked_transfer( source, destination, nbits, (head - nbits));
- nbits = 0;
- }
- else
- { Pointer temp;
- long mask;
-
- mask = low_mask( head);
- temp = *destination;
- *destination++ = ((*source++ & mask) | (temp & ~mask));
- nbits -= head;
- }
- }
- if (nbits > 0)
- {
- long nwords, tail;
-
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
- *destination++ = *source++;
-
- tail = (nbits % POINTER_LENGTH);
- if (tail > 0)
- masked_transfer( source, destination, tail,
- (POINTER_LENGTH - tail));
- }
- }
-\f
- else if (source_offset < destination_offset)
- {
- long offset1, offset2, head;
-
- offset1 = (destination_offset - source_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - destination_offset);
-
- if (nbits <= head)
- {
- long mask;
-
- mask = any_mask( nbits, (head - nbits));
- *destination =
- (((*source >> offset1) & mask) | (*destination & ~mask));
- }
- else
- {
- long mask1, mask2;
-
- { Pointer temp;
- long mask;
-
- mask = low_mask( head);
- temp = *destination;
- *destination++ =
- (((*source >> offset1) & mask) | (temp & ~mask));
- }
- nbits -= head;
- mask1 = low_mask( offset1);
- mask2 = low_mask( offset2);
- {
- long nwords, i;
-
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
- {
- i = ((*source++ & mask1) << offset2);
- *destination++ = (((*source >> offset1) & mask2) | i);
- }
- }
-\f
- {
- long tail, dest_tail;
-
- tail = (nbits % POINTER_LENGTH);
- dest_tail = (*destination & low_mask( POINTER_LENGTH - tail));
- if (tail <= offset1)
- *destination =
- (((*source & any_mask( tail, (offset1 - tail))) << offset2)
- | dest_tail);
- else
- {
- long i, j;
-
- i = ((*source++ & mask1) << offset2);
- j = (tail - offset1);
- *destination =
- (((*source & any_mask( j, (POINTER_LENGTH - j))) >> offset1)
- | i | dest_tail);
- }
- }
- }
- }
-\f
- else /* if (source_offset > destination_offset) */
- {
- long offset1, offset2, head;
-
- offset1 = (source_offset - destination_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - source_offset);
-
- if (nbits <= head)
- {
- long mask;
-
- mask = any_mask( nbits, (offset1 + (head - nbits)));
- *destination =
- (((*source << offset1) & mask) | (*destination & ~mask));
- }
- else
- {
- long dest_buffer, mask1, mask2;
-
- {
- long mask;
-
- mask = any_mask( head, offset1);
- dest_buffer =
- ((*destination & ~mask)
- | ((*source++ << offset1) & mask));
- }
- nbits -= head;
- mask1 = low_mask( offset1);
- mask2 = any_mask( offset2, offset1);
- {
- long nwords;
-
- nwords = (nbits / POINTER_LENGTH);
- if (nwords > 0)
- dest_buffer &= mask2;
- for (; (nwords > 0); nwords -= 1)
- {
- *destination++ =
- (dest_buffer | ((*source >> offset2) & mask1));
- dest_buffer = (*source++ << offset1);
- }
- }
-\f
- {
- long tail;
-
- tail = (nbits % POINTER_LENGTH);
- if (tail <= offset1)
- *destination =
- (dest_buffer
- | (*destination & low_mask( offset1 - tail))
- | ((*source >> offset2) & any_mask( tail, (offset1 - tail))));
- else
- {
- long mask;
-
- *destination++ =
- (dest_buffer | ((*source >> offset2) & mask1));
- mask = low_mask( POINTER_LENGTH - tail);
- *destination =
- ((*destination & ~mask) | ((*source << offset1) & mask));
- }
- }
- }
- }
-}
-\f
-/* Integer <-> Bit-string Conversions */
-
-long
-count_significant_bits( number, start)
- long number, start;
-{
- long significant_bits, i;
-
- significant_bits = start;
- for (i = (1 << (start - 1)); (i >= 0); i >>= 1)
- {
- if (number >= i)
- break;
- significant_bits -= 1;
- }
- return significant_bits;
-}
-
-long
-long_significant_bits( number)
- long number;
-{
- if (number < 0)
- return ULONG_SIZE;
- else
- return count_significant_bits( number, (ULONG_SIZE - 1));
-}
-
-Pointer
-zero_to_bit_string( length)
- long length;
-{
- Pointer result;
-
- result = allocate_bit_string( length);
- clear_bit_string( result);
- return result;
-}
-
-Pointer
-long_to_bit_string( length, number)
- long length, number;
-{
- if (number < 0)
- Primitive_Error( ERR_ARG_2_BAD_RANGE)
- else if (number == 0)
- zero_to_bit_string( length);
- else
- {
- if (length < long_significant_bits( number))
- Primitive_Error( ERR_ARG_2_BAD_RANGE)
- else
- {
- Pointer result;
-
- result = allocate_bit_string( length);
- clear_bit_string( result);
- Fast_Vector_Set( result, Vector_Length( result), number);
- return result;
- }
- }
-}
-\f
-Pointer
-bignum_to_bit_string( length, bignum)
- long length;
- Pointer bignum;
-{
- bigdigit *bigptr;
- long ndigits;
-
- bigptr = BIGNUM( Get_Pointer( bignum));
- if (NEG_BIGNUM( bigptr))
- Primitive_Error( ERR_ARG_2_BAD_RANGE);
- ndigits = LEN( bigptr);
- if (ndigits == 0)
- zero_to_bit_string( length);
- else
- {
- if (length <
- (count_significant_bits( *(Bignum_Top( bigptr)), SHIFT)
- + (SHIFT * (ndigits - 1))))
- Primitive_Error( ERR_ARG_2_BAD_RANGE)
- else
- {
- Pointer result;
- bigdigit *scan1, *scan2;
-
- result = allocate_bit_string( length);
- scan1 = Bignum_Bottom( bigptr);
- scan2 = ((bigdigit *) bit_string_end_ptr( result));
- for (; (ndigits > 0); ndigits -= 1)
- *--scan2 = *scan1++;
- return result;
- }
- }
-}
-\f
-/* (UNSIGNED-INTEGER->BIT-STRING length integer)
- INTEGER, which must be a non-negative integer, is converted to
- a bit-string of length LENGTH. If INTEGER is too large, an
- error is signalled. */
-
-Built_In_Primitive( Prim_unsigned_to_bit_string, 2,
- "UNSIGNED-INTEGER->BIT-STRING", 0xDC)
-{
- long length;
- Primitive_2_Args();
-
- Arg_1_Type( TC_FIXNUM);
- length = Get_Integer( Arg1);
- if (length < 0)
- Primitive_Error( ERR_ARG_1_BAD_RANGE)
- else if (Type_Code( Arg2) == TC_FIXNUM)
- return long_to_bit_string( length, Get_Integer( Arg2));
- else if (Type_Code( Arg2) == TC_BIG_FIXNUM)
- return bignum_to_bit_string( length, Arg2);
- else
- Primitive_Error( ERR_ARG_2_WRONG_TYPE)
-}
-\f
-/* (BIT-STRING->UNSIGNED-INTEGER bit-string)
- BIT-STRING is converted to the appropriate non-negative integer.
- This operation is the inverse of `integer->bit-string'. */
-
-Built_In_Primitive( Prim_bit_string_to_unsigned, 1,
- "BIT-STRING->UNSIGNED-INTEGER", 0xDD)
-{
- Pointer *scan;
- long nwords, nbits, ndigits, align_ndigits, word;
- bigdigit *bignum, *scan1, *scan2;
-
- Primitive_1_Arg();
-
- Arg_1_Type( TC_BIT_STRING);
-
- /* Count the number of significant bits.*/
- scan = bit_string_start_ptr( Arg1);
- nbits = (bit_string_length( Arg1) % POINTER_LENGTH);
- word = ((nbits > 0) ? (*scan++ & low_mask( nbits)) : *scan++);
- for (nwords = (Vector_Length( Arg1) - 1); (nwords > 0); nwords -= 1)
- {
- if (word != 0)
- break;
- else
- word = *scan++;
- }
- if (nwords == 0)
- return Make_Unsigned_Fixnum(0);
- nbits = (((nwords - 1) * POINTER_LENGTH) + long_significant_bits( word));
-
- /* Handle fixnum case. */
- if (nbits < FIXNUM_LENGTH)
- return (Make_Unsigned_Fixnum( word));
-
- /* Now the interesting one, we must make a bignum. */
- ndigits = ((nbits + (SHIFT - 1)) / SHIFT);
- align_ndigits = Align( ndigits);
- Primitive_GC_If_Needed( align_ndigits);
- bignum = BIGNUM( Free);
- Free += align_ndigits;
- Prepare_Header( bignum, ndigits, POSITIVE);
-
- scan1 = ((bigdigit *) bit_string_end_ptr( Arg1));
- scan2 = Bignum_Bottom( bignum);
- for (; (ndigits > 0); ndigits -= 1)
- *scan2++ = *--scan1;
- nbits = (nbits % SHIFT);
- if (nbits != 0)
- *scan2 = (*--scan2 & low_mask( nbits));
-
- return Make_Pointer( TC_BIG_FIXNUM, ((Pointer *) bignum));
-}
-\f
-/* These primitives should test the type of their first argument to
- verify that it is a pointer. */
-
-/* (READ-BITS! pointer offset bit-string)
- Read the contents of memory at the address (POINTER,OFFSET)
- into BIT-STRING. */
-
-Built_In_Primitive( Prim_read_bits_x, 3, "READ-BITS!", 0xDF)
-{
- long end, end_mod;
- Primitive_3_Args();
-
- Arg_2_Type( TC_FIXNUM);
- Arg_3_Type( TC_BIT_STRING);
- end = bit_string_length( Arg3);
- end_mod = (end % POINTER_LENGTH);
- copy_bits( Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2),
- Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))),
- ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
- end);
- return (NIL);
-}
-
-/* (WRITE-BITS! pointer offset bit-string)
- Write the contents of BIT-STRING in memory at the address
- (POINTER,OFFSET). */
-
-Built_In_Primitive( Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0)
-{
- long end, end_mod;
- Primitive_3_Args();
-
- Arg_2_Type( TC_FIXNUM);
- Arg_3_Type( TC_BIT_STRING);
- end = bit_string_length( Arg3);
- end_mod = (end % POINTER_LENGTH);
- copy_bits( Nth_Vector_Loc( Arg3, index_to_word( Arg3, (end - 1))),
- ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
- Nth_Vector_Loc( Arg1, 0), Get_Integer( Arg2),
- end);
- return (NIL);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.c,v 9.21 1987/01/22 14:16:33 jinx Rel $
- *
- * This file contains breakpoint utilities.
- * Disabled when not debugging the interpreter.
- *
- */
-\f
-#include "scheme.h"
-
-#ifndef ENABLE_DEBUGGING_TOOLS
-#include "Error: Not debugging but bkpt.c included"
-#endif
-
-sp_record_list SP_List = sp_nil;
-
-extern Boolean Add_a_Pop_Return_Breakpoint();
-
-static struct sp_record One_Before =
-{ ((Pointer *) 0),
- sp_nil
-};
-
-Boolean Add_a_Pop_Return_Breakpoint(SP)
-Pointer *SP;
-{ sp_record_list old = SP_List;
- SP_List = ((sp_record_list) malloc(sizeof(struct sp_record)));
- if (SP_List == sp_nil)
- { fprintf(stderr, "Could not allocate a breakpoint structure\n");
- SP_List = old;
- return false;
- }
- SP_List->sp = SP;
- SP_List->next = old;
- One_Before.next = SP_List;
- return true;
-}
-
-/* This uses register rather than fast because it is invoked
- * very often and would make things too slow.
- */
-
-void Pop_Return_Break_Point()
-{ register Pointer *SP = Stack_Pointer;
- register sp_record_list previous = &One_Before;
- register sp_record_list this = previous->next; /* = SP_List */
- for ( ;
- this != sp_nil;
- previous = this, this = this->next)
- if (this->sp == SP)
- { Handle_Pop_Return_Break();
- previous->next = this->next;
- break;
- }
- SP_List = One_Before.next;
- return;
-}
-
-/* A breakpoint can be placed here from a C debugger to examine
- the state of the world. */
-
-extern Boolean Print_One_Continuation_Frame();
-
-Handle_Pop_Return_Break()
-{ Boolean ignore;
- Pointer *Old_Stack = Stack_Pointer;
-
- printf("Pop Return Break: SP = 0x%x\n", Stack_Pointer);
- ignore = Print_One_Continuation_Frame();
- Stack_Pointer = Old_Stack;
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.23 1987/04/16 02:08:44 jinx Rel $
- *
- * This file contains breakpoint utilities.
- * Disabled when not debugging the interpreter.
- * It "shadows" definitions in default.h
- *
- */
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-\f
-struct sp_record
-{ Pointer *sp;
- struct sp_record *next;
-};
-typedef struct sp_record *sp_record_list;
-
-#define sp_nil ((sp_record_list) NULL)
-#define debug_maxslots 100
-
-#define Eval_Ucode_Hook() \
-{ \
- local_circle[local_slotno++] = Fetch_Expression(); \
- if (local_slotno >= debug_maxslots) local_slotno = 0; \
- if (local_nslots < debug_maxslots) local_nslots++; \
-}
-
-#define Pop_Return_Ucode_Hook() \
-{ \
- if (SP_List != sp_nil) \
- { Export_Registers(); \
- Pop_Return_Break_Point(); \
- Import_Registers(); \
- } \
-}
-
-/* Not implemented yet */
-
-#define Apply_Ucode_Hook()
-\f
-/* For performance metering we note the time spent handling each
- * primitive. This MIGHT help us figure out where all the time
- * goes. It should make the time zone kludge obselete someday.
- */
-
-#if false
-/* This code disabled by SAS 6/24/86 */
-struct
-{ int nprims;
- int primtime[1];
-} perfinfo_data;
-
-void Clear_Perfinfo_Data()
-{ int i;
- perfinfo_data.nprims = MAX_PRIMITIVE + 1;
- for (i = 0; i <= MAX_PRIMITIVE; i++)
- perfinfo_data.primtime[i] = 0;
-}
-
-#define Metering_Apply_Primitive(Loc, N) \
-{ \
- long Start_Time = Sys_Clock(); \
- \
- Loc = Apply_Primitive(N) \
- perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \
- Set_Time_Zone(Zone_Working); \
-}
-#endif
-#endif /* ifdef ENABLE_DEBUGGING_TOOLS */
-
+++ /dev/null
-/* -*-C-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.30 1987/04/16 02:08:53 jinx Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-\f
-/* This file contains the code to support startup of
- the SCHEME interpreter.
-
- The command line (when not running a dumped executable version) may
- take the following forms:
-
- scheme
-
- or
-
- scheme {band-name}
-
- or
-
- scheme {filespec}
- {-heap heap-size}
- {-stack stack-size}
- {-constant constant-size}
- {-utabmd utab-filename} or {-utab utab-filename}
- {other arguments ignored by the core microcode}
-
- with filespec either {-band band-name} or {{-}fasl file-name}
- arguments are optional, numbers are in 1K units. Default values
- are given above. The arguments in the long for may appear in any
- order on the command line. The allocation arguments (heap, stack,
- and constant) are ignored when scheme is an executable image. A
- warning message is printed if the command line contains them.
-
- heap-size......number of cells to allocate for user heap; this will
- be doubled to allow for 2 space GC.
- stack-size.....number of cells for control stack. This primarily
- controls maximum depth of recursion. If the flag
- USE_STACKLETS is defined, then this controls the
- size of the stacklets (not the total stack) and
- thus affects how often new stack segments must
- be allocated.
- constant-size..number of cells for constant and pure space in the
- system.
- utab-filename..name of an alternate utabmd file to use.
-
-Additional arguments may exist for particular machines; see CONFIG.H
-for details. They are created by defining a macro Command_Line_Args.
-
-*/
-\f
-#include "scheme.h"
-#include "primitive.h"
-#include "version.h"
-#include "character.h"
-#ifndef islower
-#include <ctype.h>
-#endif
-
-#define STRING_SIZE 512
-#define BLOCKSIZE 1024
-#define blocks(n) ((n)*BLOCKSIZE)
-\f
-/* Utilities for command line parsing */
-
-#define upcase(c) ((islower(c)) ? (toupper(c)) : c)
-
-void
-uppercase(to_where, from_where)
-fast char *to_where, *from_where;
-{ fast char c;
- while((c = *from_where++) != '\0') *to_where++ = upcase(c);
- *to_where = '\0';
- return;
-}
-
-int
-Parse_Option(opt_key, nargs, args, casep)
-char *opt_key, **args;
-Boolean casep;
-int nargs;
-{ int i;
- char key[STRING_SIZE], current[STRING_SIZE];
- if (casep) uppercase(key, opt_key); else strcpy(key, opt_key);
- for(i = 0; i < nargs; i++)
- { if (casep) uppercase(current, args[i]); else strcpy(current, args[i]);
- if (strcmp(key, current) == 0) return i;
- }
- return NOT_THERE;
-}
-
-long
-Def_Number(key, nargs, args, def)
-char *key, **args;
-long def;
-int nargs;
-{ int position = Parse_Option(key, nargs, args, true);
- if ((position == NOT_THERE) || (position == (nargs-1))) return def;
- else return atoi(args[position+1]);
-}
-\f
-/* Obviously, the main program */
-
-/* Used to test whether it is a dumped executable version */
-
-extern Boolean Was_Scheme_Dumped;
-Boolean Was_Scheme_Dumped = false;
-
-/* Exit is done in a different way on some operating systems (eg. VMS) */
-Exit_Scheme_Declarations;
-
-/* Main program */
-
-forward void Start_Scheme();
-extern void Clear_Memory(), Setup_Memory(), Reset_Memory();
-
-void
-main(argc, argv)
- int argc;
- char **argv;
-{ Boolean FASL_It = false;
- char *File_Name = NULL;
- int Saved_Heap_Size, Saved_Stack_Size, Saved_Constant_Size;
- extern void compiler_initialize();
-
- Saved_argc = argc;
- Saved_argv = argv;
-
- Init_Exit_Scheme();
-
- if (argc > 2)
- { int position;
- if (((position = Parse_Option("-band", argc, argv, true))
- != NOT_THERE) &&
- (position != (argc-1)))
- File_Name = argv[position+1];
- else if ((((position = Parse_Option("-fasl", argc, argv, true))
- != NOT_THERE) ||
- ((position = Parse_Option("fasl", argc, argv, true))
- != NOT_THERE)) &&
- (position != (argc-1)))
- { File_Name = argv[position + 1];
- FASL_It = true;
- }
- }
- else if ((argc == 2) && (argv[1][0] != '-')) File_Name = argv[1];
-
- if (!Was_Scheme_Dumped)
- { Heap_Size = HEAP_SIZE;
- Stack_Size = STACK_SIZE;
- Constant_Size = CONSTANT_SIZE;
- }
- else
- { Saved_Heap_Size = Heap_Size;
- Saved_Stack_Size = Stack_Size;
- Saved_Constant_Size = Constant_Size;
- }
-
- Heap_Size = Def_Number("-heap", argc, argv, Heap_Size);
- Stack_Size = Def_Number("-stack", argc, argv, Stack_Size);
- Constant_Size = Def_Number("-constant", argc, argv, Constant_Size);
-
- if (Was_Scheme_Dumped)
- { Boolean warned = false;
- printf("Executable Scheme");
- if ((Heap_Size != Saved_Heap_Size) ||
- (Stack_Size != Saved_Stack_Size) ||
- (Constant_Size != Saved_Constant_Size))
- { printf(".\n");
- fprintf(stderr,
-"Warning: Allocation parameters (heap, stack, and constant) ignored.\n");
- Heap_Size = Saved_Heap_Size;
- Stack_Size = Saved_Stack_Size;
- Constant_Size = Saved_Constant_Size;
- warned = true;
- }
- if (File_Name == NULL)
- { if (!warned) printf("; ");
- printf("Microcode Version %d.%d\n", VERSION, SUBVERSION);
- OS_Init(true);
- Enter_Interpreter();
- }
- else
- { if (!warned) printf(".\n");
- Clear_Memory(blocks(Heap_Size), blocks(Stack_Size),
- blocks(Constant_Size));
- /* We are reloading from scratch anyway. */
- Was_Scheme_Dumped = false;
- Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name);
- }
- }
- if (File_Name == NULL) File_Name = DEFAULT_BAND_NAME;
- Command_Line_Hook();
-
-/* main continues on the next page */
-\f
-/* main, continued */
-
- Setup_Memory(blocks(Heap_Size), blocks(Stack_Size),
- blocks(Constant_Size));
- compiler_initialize((long) FASL_It);
- Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name);
-}
-\f
-#define Default_Init_Fixed_Objects(Fixed_Objects) \
-{ Pointer Int_Vec, OB_Array, Error, Bad_Object, \
- The_Queue, *Dummy_Hist, The_Utilities; \
- fast long i; \
- /* Interrupt vector */ \
- Int_Vec = Make_Pointer(TC_VECTOR, Free); \
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, \
- MAX_INTERRUPT_NUMBER + 1); \
- for (i=0; i <= MAX_INTERRUPT_NUMBER; i++) *Free++ = NIL; \
- /* Error vector is not needed at boot time */ \
- Error = NIL; \
- /* Dummy History Structure */ \
- History = Make_Dummy_History(); \
- Dummy_Hist = Make_Dummy_History(); \
- /* OBArray */ \
- OB_Array = Make_Pointer(TC_VECTOR, Free); \
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, OBARRAY_SIZE); \
- for (i=0; i < OBARRAY_SIZE; i++) *Free++ = NIL; \
- /* Non Object */ \
- Bad_Object = Make_Pointer(TC_LIST, Free); \
- *Free++ = NIL; \
- *Free++ = NIL; \
- /* Initial empty work queue */ \
- The_Queue = Make_Pointer(TC_LIST, Free); \
- *Free++ = NIL; \
- *Free++ = NIL; \
- /* Empty utilities vector */ \
- The_Utilities = Make_Pointer(TC_VECTOR, Free); \
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 0); \
- \
- /* Now make the fixed objects vector */ \
- Fixed_Objects = Make_Pointer(TC_VECTOR, Free); \
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, NFixed_Objects); \
- for (i=1; i <= NFixed_Objects; i++) *Free++ = NIL; \
- User_Vector_Set(Fixed_Objects, Non_Object, Bad_Object); \
- User_Vector_Set(Fixed_Objects, System_Interrupt_Vector, Int_Vec); \
- User_Vector_Set(Fixed_Objects, System_Error_Vector, Error); \
- User_Vector_Set(Fixed_Objects, OBArray, OB_Array); \
- User_Vector_Set(Fixed_Objects, Dummy_History, \
- Make_Pointer(TC_HUNK3, Dummy_Hist)); \
- User_Vector_Set(Fixed_Objects, State_Space_Tag, TRUTH); \
- User_Vector_Set(Fixed_Objects, Bignum_One, \
- Fix_To_Big(Make_Unsigned_Fixnum(1))); \
- User_Vector_Set(Fixed_Objects, Me_Myself, Fixed_Objects); \
- User_Vector_Set(Fixed_Objects, The_Work_Queue, The_Queue); \
- User_Vector_Set(Fixed_Objects, Utilities_Vector, The_Utilities); \
-}
-\f
-/* Boot Scheme */
-
-void
-Start_Scheme(Start_Prim, File_Name)
- int Start_Prim;
- char *File_Name;
-{
- extern Pointer make_primitive();
- Pointer FName, Init_Prog, *Fasload_Call, prim;
- fast long i;
- Boolean I_Am_Master; /* Butterfly test */
-
- I_Am_Master = (Start_Prim != BOOT_GET_WORK);
- if (I_Am_Master)
- printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
- OS_Init(I_Am_Master);
- if (I_Am_Master)
- {
- for (i = 0; i < FILE_CHANNELS; i++)
- {
- Channels[i] = NULL;
- }
- Init_Fixed_Objects();
- }
-\f
-/* The initial program to execute is one of
- (SCODE-EVAL (BINARY-FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT),
- (LOAD-BAND <file-name>), or
- ((GET-WORK))
- depending on the value of Start_Prim.
-*/
-
- FName = C_String_To_Scheme_String(File_Name);
- Fasload_Call = Free;
- switch (Start_Prim)
- {
- case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
- *Free++ = make_primitive("BINARY-FASLOAD");
- *Free++ = FName;
- Init_Prog = Make_Pointer(TC_PCOMB2, Free);
- *Free++ = make_primitive("SCODE-EVAL");
- *Free++ = Make_Pointer(TC_PCOMB1, Fasload_Call);
- *Free++ = Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL);
- break;
-
- case BOOT_LOAD_BAND: /* (LOAD-BAND <file>) */
- *Free++ = make_primitive("LOAD-BAND");
- *Free++ = FName;
- Init_Prog = Make_Pointer(TC_PCOMB1, Fasload_Call);
- break;
-
- case BOOT_GET_WORK: /* ((GET-WORK)) */
- *Free++ = make_primitive("GET-WORK");
- *Free++ = NIL;
- Init_Prog = Make_Pointer(TC_COMBINATION, Free);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 1);
- *Free++ = Make_Non_Pointer(TC_PCOMB1, Fasload_Call);
- break;
-
- default:
- fprintf(stderr, "Unknown boot time option: %d\n", Start_Prim);
- Microcode_Termination(TERM_BAD_PRIMITIVE);
- /*NOTREACHED*/
- }
-
-/* Start_Scheme continues on the next page */
-\f
-/* Start_Scheme, continued */
-
- /* Setup registers */
-
- IntEnb = INT_Mask;
- IntCode = 0;
- Env = Make_Non_Pointer(GLOBAL_ENV, 0);
- Trapping = false;
- Return_Hook_Address = NULL;
-
- /* Give the interpreter something to chew on, and ... */
-
- Will_Push(CONTINUATION_SIZE);
- Store_Return(RC_END_OF_COMPUTATION);
- Store_Expression(NIL);
- Save_Cont();
- Pushed();
-
- Store_Expression(Init_Prog);
-
- /* Go to it! */
-
- if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
- {
- fprintf(stderr, "Configuration won't hold initial data.\n");
- Microcode_Termination(TERM_EXIT);
- }
- Entry_Hook();
- Enter_Interpreter();
- /*NOTREACHED*/
-}
-
-Enter_Interpreter()
-{
- jmp_buf Orig_Eval_Point;
- Back_To_Eval = (jmp_buf *) Orig_Eval_Point;
-
- Interpret(Was_Scheme_Dumped);
- fprintf(stderr, "\nThe interpreter returned to top level!\n");
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
-}
-\f
-#define IDENTITY_LENGTH 20 /* Plenty of room */
-#define ID_RELEASE 0 /* Scheme system release */
-#define ID_MICRO_VERSION 1 /* Microcode version */
-#define ID_MICRO_MOD 2 /* Microcode modification */
-#define ID_PRINTER_WIDTH 3 /* Width of console (chars) */
-#define ID_PRINTER_LENGTH 4 /* Height of console (chars) */
-#define ID_NEW_LINE_CHARACTER 5 /* #\Newline */
-#define ID_FLONUM_PRECISION 6 /* Flonum mantissa (bits) */
-#define ID_FLONUM_EXPONENT 7 /* Flonum exponent (bits) */
-#define ID_OS_NAME 8 /* OS name (string) */
-#define ID_OS_VARIANT 9 /* OS variant (string) */
-
-Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5)
-{
- Pointer *Result;
- long i;
- Primitive_0_Args ();
-
- Primitive_GC_If_Needed (IDENTITY_LENGTH + VECTOR_DATA);
- Result = Free;
- *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, IDENTITY_LENGTH));
- for (i = 0; (i < IDENTITY_LENGTH); i += 1)
- *Free++ = NIL;
- Result[(ID_RELEASE + VECTOR_DATA)]
- = (C_String_To_Scheme_String (RELEASE));
- Result[(ID_MICRO_VERSION + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (VERSION));
- Result[(ID_MICRO_MOD + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (SUBVERSION));
- Result[(ID_PRINTER_WIDTH + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (NColumns ()));
- Result[(ID_PRINTER_LENGTH + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (NLines ()));
- Result[(ID_NEW_LINE_CHARACTER + VECTOR_DATA)]
- = (c_char_to_scheme_char ('\n'));
- Result[(ID_FLONUM_PRECISION + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (FLONUM_MANTISSA_BITS));
- Result[(ID_FLONUM_EXPONENT + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (FLONUM_EXPT_SIZE));
- Result[(ID_OS_NAME + VECTOR_DATA)]
- = (C_String_To_Scheme_String (OS_Name));
- Result[(ID_OS_VARIANT + VECTOR_DATA)]
- = (C_String_To_Scheme_String (OS_Variant));
- return (Make_Pointer (TC_VECTOR, Result));
-}
-\f
-Built_In_Primitive(Prim_Microcode_Tables_Filename,
- 0, "MICROCODE-TABLES-FILENAME", 0x180)
-{ fast char *From, *To;
- char *Prefix, *Suffix;
- fast long Count;
- long position;
- Pointer Result;
- Primitive_0_Args();
-
- if ((((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true))
- != NOT_THERE) &&
- (position != (Saved_argc - 1))) ||
- (((position = Parse_Option("-utab", Saved_argc, Saved_argv, true))
- != NOT_THERE) &&
- (position != (Saved_argc - 1))))
- { Prefix = "";
- Suffix = Saved_argv[position + 1];
- }
- else
- { Prefix = SCHEME_SOURCES_PATH;
- Suffix = UCODE_TABLES_FILENAME;
- }
- /* Find the length of the combined string, and allocate. */
- Count = 0;
- for (From = Prefix; *From++ != '\0'; )
- { Count += 1;
- }
- for (From = Suffix; *From++ != '\0'; )
- { Count += 1;
- }
- Primitive_GC_If_Needed(STRING_CHARS +
- ((Count + sizeof(Pointer)) /
- sizeof(Pointer)));
-
- /* Append both substrings. */
- Result = Make_Pointer(TC_CHARACTER_STRING, Free);
- To = (char *) &(Free[STRING_CHARS]);
- for (From = &(Prefix[0]); *From != '\0'; )
- { *To++ = *From++;
- }
- for (From = &(Suffix[0]); *From != '\0'; )
- { *To++ = *From++;
- }
- *To = '\0';
- Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer));
- Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
- Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
- ((Free - Get_Pointer(Result)) - 1)));
- return Result;
-}
-\f
-/*VARARGS1*/
-term_type
-Microcode_Termination(Err, Micro_Error)
-long Err, Micro_Error;
-{ long value = 1;
- Pointer Term_Vector;
- if ((Err != TERM_HALT) &&
- (Valid_Fixed_Obj_Vector()) &&
- (Type_Code(Term_Vector =
- Get_Fixed_Obj_Slot(Termination_Proc_Vector)) ==
- TC_VECTOR) &&
- (Vector_Length(Term_Vector) > Err))
- { Pointer Handler = User_Vector_Ref(Term_Vector, Err);
- if (Handler != NIL)
- {
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS +
- ((Err == TERM_NO_ERROR_HANDLER) ? 5 : 4));
- Store_Return(RC_HALT);
- Store_Expression(Make_Unsigned_Fixnum(Err));
- Save_Cont();
- if (Err == TERM_NO_ERROR_HANDLER)
- Push(Make_Unsigned_Fixnum(Micro_Error));
- Push(Val); /* Arg 3 */
- Push(Fetch_Env()); /* Arg 2 */
- Push(Fetch_Expression()); /* Arg 1 */
- Push(Handler); /* The handler function */
- Push(STACK_FRAME_HEADER + ((Err==TERM_NO_ERROR_HANDLER) ? 4 : 3));
- Pushed();
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
- }
- }
-
-/* Microcode_Termination continues on the next page */
-\f
-/* Microcode_Termination, continued */
-
- switch(Err)
- { case TERM_BAD_PRIMITIVE:
- printf("\nBad primitive invoked.\n"); break;
- case TERM_BAD_PRIMITIVE_DURING_ERROR:
- printf("Error during unknown primitive.\n"); break;
- case TERM_BAD_ROOT:
- printf("Band file isn't a control point.\n"); break;
- case TERM_BAD_STACK:
- printf("Control stack messed up.\n"); break;
- case TERM_BROKEN_HEART:
- printf("Broken heart encountered.\n"); break;
- case TERM_COMPILER_DEATH:
- printf("Compiled code entered without compiler support.\n"); break;
- case TERM_DISK_RESTORE:
- printf("DISK restore.\n"); break;
- case TERM_EOF:
- printf("\nEnd of input stream reached.\n"); break;
- case TERM_END_OF_COMPUTATION:
- Print_Expression(Val, "End of computation; final result"); break;
- case TERM_EXIT:
- printf("Inconsistency detected.\n"); break;
- case TERM_GC_OUT_OF_SPACE:
- printf("Out of space after GC. Needed %d, have %d\n",
- Get_Integer(Fetch_Expression()), Space_Before_GC());
- break;
- case TERM_HALT:
- printf("User halt code.\n"); value = 0; break;
- case TERM_INVALID_TYPE_CODE:
- printf("Bad Type: check GC_Type map.\n"); break;
- case TERM_NO_ERROR_HANDLER:
- printf("\nNo handler for error code: %d\n", Micro_Error); break;
- case TERM_NO_INTERRUPT_HANDLER:
- printf("No interrupt handler.\n"); break;
- case TERM_NON_EXISTENT_CONTINUATION:
- printf("No such return code 0x%08x.\n", Fetch_Return()); break;
- case TERM_NON_POINTER_RELOCATION:
- printf("Non pointer relocation!?\n"); break;
- case TERM_STACK_ALLOCATION_FAILED:
- printf("No space for stack!?\n"); break;
- case TERM_STACK_OVERFLOW:
- printf("Recursion depth exceeded.\n"); break;
- case TERM_TERM_HANDLER:
- printf("Termination handler returned.\n"); break;
- case TERM_UNIMPLEMENTED_CONTINUATION:
- printf("Return code not implemented.\n"); break;
- case TERM_NO_SPACE:
- printf("Not enough memory.\n"); break;
- case TERM_SIGNAL:
- printf("Unhandled signal received.\n"); break;
- default: printf("Termination code 0x%x.\n", Err);
- }
- if ((Trace_On_Error) && (Err != TERM_HALT))
- { printf( "\n\nStack trace:\n\n");
- Back_Trace();
- }
- OS_Flush_Output_Buffer();
- OS_Quit();
- Reset_Memory();
- Exit_Hook();
- Exit_Scheme(value);
-}
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/breakup.c,v 9.21 1987/01/22 14:11:34 jinx Rel $ */
-\f
-#include <stdio.h>
-
-#ifndef isdigit
-#include <ctype.h>
-#endif
-
-#define boolean char
-#define false 0
-#define true 1
-
-#define isoctal(c) (isdigit(c) && (c != '8') && (c != '9'))
-
-int get_a_char()
-{ register int c;
- register int count = 2;
- for (c = getchar();
- isoctal(c) && count >= 0;
- c = getchar(), count -=1)
- putchar(c);
- if (count != 2) return c;
- putchar(c);
- return getchar();
-}
-
-main()
-{ register int c;
- register boolean after_new_line = true;
- while ((c = getchar()) != EOF)
-re_dispatch:
- switch(c)
- { case '\f':
- break;
- case ',':
- putchar(c);
- while (((c = getchar()) == ' ') || (c == '\t'))
- if (c == EOF)
- { fprintf(stderr, "Confused expression: ,\n");
- exit(1);
- }
- if (c == '\n')
- { putchar(c);
- after_new_line = true;
- break;
- }
- putchar(' ');
- goto re_dispatch;
- case ';':
- case ':':
- case '?':
- case '}':
- putchar(c);
- putchar('\n');
- after_new_line = true;
- break;
- case '\n':
- if (!after_new_line)
- { after_new_line = true;
- putchar('\n');
- }
- break;
- case '\'':
- putchar(c);
- c = getchar();
- if (c == EOF)
- { fprintf(stderr, "Confused character: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c == '\n')
- { fprintf(stderr, "Confused character: \\n\n");
- after_new_line = true;
- break;
- }
- if (c == '\'')
- { fprintf(stderr, "Confused character: \\\'\n");
- break;
- }
- if (c == '\\')
- c = get_a_char();
- else c = getchar();
- if (c == EOF)
- { fprintf(stderr, "Confused character: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c != '\'')
- fprintf(stderr, "Confused character: %c = 0x%x\n",
- c);
- break;
- case '"':
- after_new_line == false;
- putchar(c);
- c = getchar();
- while (true)
- { while ((c != EOF) &&
- (c != '"') &&
- (c != '\n') &&
- (c != '\\'))
- { putchar(c);
- c = getchar();
- }
- if (c == EOF)
- { fprintf(stderr, "Confused string: EOF\n");
- exit(1);
- }
- putchar(c);
- if (c == '\n')
- { fprintf(stderr, "Confused string: \\n\n");
- after_new_line = true;
- break;
- }
- if (c == '"') break;
- if (c == '\\')
- c = get_a_char();
- }
- break;
- case '#':
- if (after_new_line)
- { while (((c = getchar()) != EOF) && (c != '\n')) ;
- if (c == EOF) exit(0);
- break;
- }
- putchar(c);
- break;
- case '{':
- if (!after_new_line)
- putchar('\n');
- /* Fall Through */
- default:
- after_new_line = false;
- putchar(c);
- }
- fflush(stdout);
- exit(0);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.21 1987/04/16 02:18:50 jinx Exp $ */
-
-/* Character primitives. */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "character.h"
-#include <ctype.h>
-\f
-#define define_ascii_char_guarantee(procedure_name, wta, bra) \
-long \
-procedure_name (argument) \
- Pointer argument; \
-{ \
- fast long ascii; \
- \
- if (! (character_p (argument))) \
- wta (); \
- ascii = (scheme_char_to_c_char (argument)); \
- if (ascii == NOT_ASCII) \
- bra (); \
- return (ascii); \
-}
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_1,
- error_wrong_type_arg_1,
- error_bad_range_arg_1)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_2,
- error_wrong_type_arg_2,
- error_bad_range_arg_2)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_3,
- error_wrong_type_arg_3,
- error_bad_range_arg_3)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_4,
- error_wrong_type_arg_4,
- error_bad_range_arg_4)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_5,
- error_wrong_type_arg_5,
- error_bad_range_arg_5)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_6,
- error_wrong_type_arg_6,
- error_bad_range_arg_6)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_7,
- error_wrong_type_arg_7,
- error_bad_range_arg_7)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_8,
- error_wrong_type_arg_8,
- error_bad_range_arg_8)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_9,
- error_wrong_type_arg_9,
- error_bad_range_arg_9)
-
-define_ascii_char_guarantee (guarantee_ascii_char_arg_10,
- error_wrong_type_arg_10,
- error_bad_range_arg_10)
-\f
-#define define_ascii_integer_guarantee(procedure_name, wta, bra) \
-long \
-procedure_name (argument) \
- Pointer argument; \
-{ \
- fast long ascii; \
- \
- if (! (fixnum_p (argument))) wta (); \
- if (fixnum_negative_p (argument)) bra (); \
- ascii = (pointer_datum (argument)); \
- if (ascii >= MAX_ASCII) bra (); \
- return (ascii); \
-}
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_1,
- error_wrong_type_arg_1,
- error_bad_range_arg_1)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_2,
- error_wrong_type_arg_2,
- error_bad_range_arg_2)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_3,
- error_wrong_type_arg_3,
- error_bad_range_arg_3)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_4,
- error_wrong_type_arg_4,
- error_bad_range_arg_4)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_5,
- error_wrong_type_arg_5,
- error_bad_range_arg_5)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_6,
- error_wrong_type_arg_6,
- error_bad_range_arg_6)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_7,
- error_wrong_type_arg_7,
- error_bad_range_arg_7)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_8,
- error_wrong_type_arg_8,
- error_bad_range_arg_8)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_9,
- error_wrong_type_arg_9,
- error_bad_range_arg_9)
-
-define_ascii_integer_guarantee (guarantee_ascii_integer_arg_10,
- error_wrong_type_arg_10,
- error_bad_range_arg_10)
-\f
-Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14)
-{
- long bucky_bits, code;
- Primitive_2_Args ();
-
- code = (guarantee_index_arg_1 (Arg1, MAX_CODE));
- bucky_bits = (guarantee_index_arg_2 (Arg2, MAX_BITS));
- return (make_char (bucky_bits, code));
-}
-
-Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15)
-{
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- return (Make_Unsigned_Fixnum (char_bits (Arg1)));
-}
-
-Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17)
-{
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- return (Make_Unsigned_Fixnum (char_code (Arg1)));
-}
-
-Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B)
-{
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- return (Make_Unsigned_Fixnum (Arg1 & MASK_EXTNDD_CHAR));
-}
-
-Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34)
-{
- Primitive_1_Arg ();
-
- return
- (Make_Non_Pointer (TC_CHARACTER,
- (guarantee_index_arg_1 (Arg1, MAX_EXTNDD_CHAR))));
-}
-\f
-long
-char_downcase (c)
- long c;
-{
- c = (char_to_long (c));
- return ((isupper (c)) ? ((c - 'A') + 'a') : c);
-}
-
-long
-char_upcase (c)
- long c;
-{
- c = (char_to_long (c));
- return ((islower (c)) ? ((c - 'a') + 'A') : c);
-}
-
-Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35)
-{
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1)))));
-}
-
-Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36)
-{
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1)))));
-}
-
-Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37)
-{
- Primitive_1_Arg ();
-
- return (c_char_to_scheme_char (guarantee_ascii_integer_arg_1 (Arg1)));
-}
-
-Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39)
-{
- Primitive_1_Arg ();
-
- return (Make_Unsigned_Fixnum (guarantee_ascii_char_arg_1 (Arg1)));
-}
-
-Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38)
-{
- long ascii;
- Primitive_1_Arg ();
-
- guarantee_char_arg_1 ();
- ascii = (scheme_char_to_c_char (Arg1));
- return ((ascii == NOT_ASCII) ? NIL : (Make_Unsigned_Fixnum (ascii)));
-}
-\f
-forward Boolean ascii_control_p();
-
-long
-ascii_to_mit_ascii (ascii)
- long ascii;
-{
- long bucky_bits, code;
-
- bucky_bits = (((ascii & 0200) != 0) ? CHAR_BITS_META : 0);
- code = (ascii & 0177);
- if (ascii_control_p (code))
- {
- code |= 0100; /* Convert to non-control code. */
- bucky_bits |= CHAR_BITS_CONTROL;
- }
- return ((bucky_bits << CODE_LENGTH) | code);
-}
-
-long
-mit_ascii_to_ascii (mit_ascii)
- long mit_ascii;
-{
- long bucky_bits, code;
-
- bucky_bits = ((mit_ascii >> CODE_LENGTH) & CHAR_MASK_BITS);
- code = (mit_ascii & CHAR_MASK_CODE);
- if ((bucky_bits & (~ CHAR_BITS_CONTROL_META)) != 0)
- return (NOT_ASCII);
- else
- {
- if ((bucky_bits & CHAR_BITS_CONTROL) != 0)
- {
- code = (char_upcase (code) & (~ 0100));
- if (!ascii_control_p (code))
- return (NOT_ASCII);
- }
- else
- {
- if (ascii_control_p (code))
- return (NOT_ASCII);
- }
- return (((bucky_bits & CHAR_BITS_META) != 0) ? (code | 0200) : code);
- }
-}
-\f
-Boolean
-ascii_control_p (code)
- int code;
-{
- switch (code)
- {
- case 000:
- case 001:
- case 002:
- case 003:
- case 004:
- case 005:
- case 006:
- case 007:
- case 016:
- case 017:
- case 020:
- case 021:
- case 022:
- case 023:
- case 024:
- case 025:
- case 026:
- case 027:
- case 030:
- case 031:
- case 034:
- case 035:
- case 036:
- return (true);
-
- default:
- return (false);
- }
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.24 1987/04/16 02:20:07 jinx Exp $
- *
- * This file contains the configuration information and the information
- * given on the command line on Unix.
- *
- */
-\f
-/* Default pathnames. */
-
-#ifndef DEFAULT_BAND_NAME
-#define DEFAULT_BAND_NAME "scm:scheme.bin"
-#endif
-#ifndef SCHEME_SOURCES_PATH
-#define SCHEME_SOURCES_PATH "scm:"
-#endif
-
-#ifndef butterfly
-#ifndef unix
-/* On unix, these are part of the make file. */
-
-/* Runtime debugging flags, with appropriate defaults: */
-
-/* To debug the interpreter code itself, define ENABLE_DEBUGGING_TOOLS */
-/* #define ENABLE_DEBUGGING_TOOLS */
-
-/* If runtime HISTORY recording (a Scheme code debugging tool) is desired. */
-#define COMPILE_HISTORY
-
-/* To enable the STEPPER. Incompatible with futures. */
-/* #define COMPILE_STEPPER */
-
-/* To enable FUTURES (a multiprocessor / multiprocessing extension).
- This option is incompatible with the stepper.
- Future.c must also be compiled. */
-/* #define COMPILE_FUTURES */
-
-/* To enable stacklets (mostly useful with FUTURES). These allow the
- stack to be allocated in small chunks from the heap, rather than
- in a single contiguous area at start up time. The use of the this
- option is incompatible with the stepper and compiler.
-*/
-/* #define USE_STACKLETS */
-#endif
-#endif
-\f
-/* Some configuration consistency testing */
-
-#ifdef COMPILE_STEPPER
-#ifdef COMPILE_FUTURES
-#include "Error: Futures and stepping are not currently compatible."
-#endif
-#endif
-
-#ifdef USE_STACKLETS
-#ifdef COMPILE_STEPPER
-#include "Error: The stepper doesn't work with stacklets."
-#endif
-#endif
-\f
-/* These C type definitions are needed by everybody.
- They should not be here, but it is unavoidable. */
-
-typedef char Boolean;
-#define true 1
-#define false 0
-
-/* This defines it so that C will be happy.
- The various fields are defined in object.h */
-
-typedef unsigned long Pointer;
-\f
-/* Operating System / Machine dependencies:
-
- For each implementation, be sure to specify FASL_INTERNAL_FORMAT,
- the various sizes, and the floating point information.
- Make sure that there is an appropriate FASL_<machine name>.
- If you do not know these parameters, try compiling and running the
- wsize program ("make wsize" if on a unix variant). It may not run,
- but if it does, it will probably compute the correct information.
-
- Note that the C type void is used in the sources. If your version
- of C does not have this type, you should bypass it.
- This can be done by inserting the preprocessor command
- '#define void' in this file.
-
- CHAR_SIZE is the size of a character in bits.
-
- USHORT_SIZE is the size of an unsigned short in bits. It should
- be equivalent to (sizeof(unsigned short) * CHAR_SIZE), but is
- available to the preprocessor.
-
- ULONG_SIZE is the size of an unsigned long in bits.
-
- FLONUM_EXPT_SIZE is the number of bits in the largest positive
- exponent of a (double) floating point number.
- Note that if excess exponents are used in the representation,
- this number is one less than the size in bits of the exponent field.
-
- FLONUM_MANTISSA_BITS is the number of bits in the (positive) mantissa
- of a (double) floating point number. It includes the hidden bit if
- the representation uses them.
-
- Thus 2+FLONUM_EXPT_SIZE+FLONUM_MANTISSA_BITS(-1 if hidden bit is used)
- should be the size in bits of a (double) floating point number.
-
- FLONUM_EXPONENT_SIZE
- MAX_FLONUM_EXPONENT = 2 - 1
-
- Other flags (the safe option is NOT to define them, which will
- sacrifice speed for safety):
-
- b32 should be defined for machines whose word size
- (CHAR_SIZE*sizeof(long)) is 32 bits. The information is redundant,
- but some C compilers do not do constant folding when shifts are
- involved, so it sometimes makes a big difference to define the
- constants directly rather than in terms of other constants.
- Similar things can be done for other word sizes.
-*/
-\f
-/* Heap_In_Low_Memory should be defined if malloc returns the lowest
- available memory and thus all addresses will fit in the datum portion
- of a Scheme Pointer. The datum portion of a Scheme Pointer is 8 bits
- less than the length of a C long.
-
- UNSIGNED_SHIFT is defined if right shifting an unsigned long
- (i.e. Pointer) results in a logical (vs. arithmetic) shift.
- Setting the flag allows faster type code extraction.
-
- BELL is the character which rings the terminal bell.
-
- The following switches are used to use the system provided library
- routines rather than the emulated versions in the Scheme sources.
- The system provided ones are more accurate and potentially more
- efficient.
-
- HAS_FLOOR should be defined if the system has the double precision
- procedures floor and ceil. On Unix, look for floor(3M).
-
- HAS_FREXP should be defined if the system has the double precision
- procedures ldexp and frexp. On Unix, look for frexp(3C).
-
- FLOATING_ALIGNMENT should be defined if the system requires
- floating point numbers (double) to be aligned more strictly than
- Pointers (long). The value must be a mask of the low order
- bits which are required to be zero for the storage address.
- For example, a value of 0x7 requires octabyte alignment on a
- machine where addresses are specified in bytes. The alignment
- must be an integral multiple of the length of a long, since
- it must pad with an explicit Pointer value.
- This option is not completely working right now.
-
-*/
-
-#define FASL_UNKNOWN 0
-#define FASL_PDP10 1
-#define FASL_VAX 2
-#define FASL_HP_9000_200 3
-#define FASL_NU 4
-#define FASL_HP_9000_500 5
-#define FASL_SUN 6
-#define FASL_BFLY 7
-#define FASL_CYBER 8
-#define FASL_CELERITY 9
-#define FASL_HP_SPECTRUM 10
-#define FASL_UMAX 11
-\f
-/* These (pdp10 and nu) haven't worked in a while.
- * Should be upgraded or flushed some day.
- */
-
-#ifdef pdp10
-#define Heap_In_Low_Memory
-#define CHAR_SIZE 36 / * Ugh! Supposedly fixed in newer Cs * /
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_PDP10
-#endif
-
-#ifdef nu
-#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_NU
-#define FLONUM_EXPT_SIZE 7
-#define FLONUM_MANTISSA_BITS 56
-#define MAX_FLONUM_EXPONENT 127
-#define HAS_FREXP
-#ifdef quick
-/* Bignum code fails for certain variables in registers because of a
- compiler bug!
-*/
-#undef quick
-#define quick
-#endif
-#endif
-\f
-#ifdef vax
-/* Amazingly unix and vms agree on all these */
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_VAX
-#define FLONUM_EXPT_SIZE 7
-#define FLONUM_MANTISSA_BITS 56 /* D format */
-#define MAX_FLONUM_EXPONENT 127
-#define HAS_FLOOR
-#define HAS_FREXP
-
-/* Not on these, however */
-
-#ifdef vms
-
-/* Pre version 4 VMS C has not void type, thus make it go away */
-/* #define void */
-/* Name conflict in VMS with system variable */
-#define Free Free_Register
-
-/* exit(0) produces horrible message on VMS */
-
-#define NORMAL_EXIT 1
-
-#define Exit_Scheme_Declarations static jmp_buf Exit_Point
-
-#define Init_Exit_Scheme() \
-{ \
- int Which_Way = setjmp(Exit_Point); \
- if (Which_Way == NORMAL_EXIT) \
- return; \
-}
-
-#define Exit_Scheme(value) \
-if (value != 0) \
- exit(value); \
-longjmp(Exit_Point, NORMAL_EXIT)
-
-#else /* not a vms */
-
-/* Vax Unix C compiler bug */
-
-#define double_into_fixnum(what, target) \
-{ \
- long For_Vaxes_Sake = ((long) what); \
- \
- target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
-}
-
-#endif /* not vms */
-#endif /* vax */
-\f
-#ifdef hp9000s200 /* and s300, pretty indistinguishable */
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_HP_9000_200
-#define FLONUM_EXPT_SIZE 10
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 1023
-#define HAS_FLOOR
-#define HAS_FREXP
-/* C compiler bug in GC_Type */
-#define term_type int
-#endif
-
-#ifdef hp9000s500
-/* An unfortunate fact of life on this machine:
- the C heap is in high memory thus Heap_In_Low_Memory is not
- defined and the whole thing runs slowly. *Sigh*
-*/
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_HP_9000_500
-#define FLONUM_EXPT_SIZE 10
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 1023
-#define HAS_FLOOR
-#define HAS_FREXP
-
-/* C Compiler bug when constant folding and anchor pointing */
-#define And2(x, y) ((x) ? (y) : false)
-#define And3(x, y, z) ((x) ? ((y) ? (z) : false) : false)
-#define Or2(x, y) ((x) ? true : (y))
-#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z)))
-#endif
-\f
-#ifdef sun
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_SUN
-#define FLONUM_EXPT_SIZE 7
-#define FLONUM_MANTISSA_BITS 56
-#define MAX_FLONUM_EXPONENT 127
-#define HAS_FLOOR
-#define HAS_FREXP
-#endif
-
-#ifdef butterfly
-#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_BFLY
-#define FLONUM_EXPT_SIZE 7
-#define FLONUM_MANTISSA_BITS 56
-#define MAX_FLONUM_EXPONENT 127
-#include <public.h>
-#define HAS_FREXP
-#define STACK_SIZE 4 /* 4K objects */
-#endif
-
-#ifdef cyber180
-/* Word size is 64 bits. */
-#define Heap_In_Low_Memory
-#define CHAR_SIZE 8
-#define USHORT_SIZE ???
-#define ULONG_SIZE ???
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_CYBER
-#define FLONUM_EXPT_SIZE 14
-#define FLONUM_MANTISSA_BITS 48
-/* Not the full range, or so the manual says. */
-#define MAX_FLONUM_EXPONENT 4095
-/* The Cyber180 C compiler manifests a bug in hairy conditional
- expressions */
-#define Conditional_Bug
-#endif
-\f
-#ifdef celerity
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_CELERITY
-#define FLONUM_EXPT_SIZE 11
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 2047
-#endif
-
-#ifdef spectrum
-/* Heap resides in "Quad 1", and hence memory addresses have a 1
- in the second MSBit. This is taken care of in object.h, and is
- still considered Heap_In_Low_Memory.
-*/
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_HP_SPECTRUM
-#define FLONUM_EXPT_SIZE 10
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 1023
-#define FLOATING_ALIGNMENT 0x7 /* Low 3 MBZ for float storage */
-#define HAS_FLOOR
-#define HAS_FREXP
-#endif
-
-#ifdef umax
-#define Heap_In_Low_Memory
-#define UNSIGNED_SHIFT
-#define CHAR_SIZE 8
-#define USHORT_SIZE 16
-#define ULONG_SIZE 32
-#define BELL '\007'
-#define FASL_INTERNAL_FORMAT FASL_UMAX
-#define FLONUM_EXPT_SIZE 10
-#define FLONUM_MANTISSA_BITS 53
-#define MAX_FLONUM_EXPONENT 1023
-#define HAS_FLOOR
-#define HAS_FREXP
-#endif
-\f
-/* Make sure that some definition applies.
- If this error occurs, and the parameters of the
- configuration are unknown, try the Wsize program.
-*/
-
-#ifndef CHAR_SIZE
-#include "Error: config.h: Unknown configuration."
-#endif
-
-#if (ULONG_SIZE == 32)
-#define b32
-#endif
-\f
-/* Default "segment" sizes */
-
-#ifndef STACK_SIZE
-#ifndef USE_STACKLETS
-#define STACK_SIZE 30 /* Default Kcells for stack */
-#else
-#define STACK_SIZE 256 /* Default stacklet size */
-#endif
-#endif
-#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 180 /* Default Kcells for constant */
-#endif
-#ifndef HEAP_SIZE
-#define HEAP_SIZE 250 /* Default Kcells for each heap */
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.24 1987/04/16 02:20:20 jinx Rel $
- *
- * Named constants used throughout the interpreter
- *
- */
-\f
-#if (CHAR_SIZE != 8)
-#define MAX_CHAR ((1<<CHAR_SIZE)-1)
-#else
-#define MAX_CHAR 0xFF
-#endif
-
-#define PI 3.1415926535
-#define STACK_FRAME_HEADER 1
-
-/* Precomputed typed pointers */
-#ifndef b32 /* Safe version */
-
-#define NIL Make_Non_Pointer(TC_NULL, 0)
-#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
-
-#else /* 32 bit word */
-#define NIL 0x00000000
-#define TRUTH 0x08000000
-#define FIXNUM_ZERO 0x1A000000
-#define BROKEN_HEART_ZERO 0x22000000
-#endif /* b32 */
-
-#define NOT_THERE -1 /* Command line parser */
-\f
-/* Assorted sizes used in various places */
-
-#ifdef MAXPATHLEN
-#define FILE_NAME_LENGTH MAXPATHLEN
-#else
-#define FILE_NAME_LENGTH 1024 /* Max. chars. in a file name */
-#endif
-
-#define OBARRAY_SIZE 3001 /* Interning hash table */
-
-#ifndef STACK_GUARD_SIZE
-#define STACK_GUARD_SIZE 4096 /* Cells between constant and
- stack before overflow
- occurs */
-#endif
-
-/* Some versions of stdio define this. */
-#ifndef _NFILE
-#define _NFILE 15
-#endif
-
-#define FILE_CHANNELS _NFILE
-
-#define MAX_LIST_PRINT 10
-
-#define ILLEGAL_PRIMITIVE -1
-
-/* Hashing algorithm for interning */
-
-#define MAX_HASH_CHARS 5
-#define LENGTH_MULTIPLIER 5
-#define SHIFT_AMOUNT 2
-
-/* Last immediate reference trap. */
-
-#define TRAP_MAX_IMMEDIATE 9
-
-/* For headers in pure / constant area */
-
-#define END_OF_BLOCK TC_FIXNUM
-#define CONSTANT_PART TC_TRUE
-#define PURE_PART TC_FALSE
-
-/* Primitive flow control codes: directs computation after
- * processing a primitive application.
- */
-#define PRIM_DONE -1
-#define PRIM_DO_EXPRESSION -2
-#define PRIM_APPLY -3
-#define PRIM_INTERRUPT -4
-#define PRIM_NO_TRAP_EVAL -5
-#define PRIM_NO_TRAP_APPLY -6
-#define PRIM_POP_RETURN -7
-\f
-/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
-
-#define INT_Stack_Overflow 1 /* Local interrupt */
-#define INT_Global_GC 2
-#define INT_GC 4 /* Local interrupt */
-#define INT_Global_1 8
-#define INT_Character 16 /* Local interrupt */
-#define INT_Global_2 32
-#define INT_Timer 64 /* Local interrupt */
-#define INT_Global_3 128
-#define INT_Global_Mask \
- (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
-#define Global_GC_Level 1
-#define Global_1_Level 3
-#define Global_2_Level 5
-#define Global_3_Level 7
-#define MAX_INTERRUPT_NUMBER 7
-
-#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
-
-/* Error case detection for precomputed constants */
-/* VMS preprocessor does not like line continuations in conditionals */
-
-#define Are_The_Constants_Incompatible \
-((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \
- (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
- (TC_CHARACTER_STRING != 0x1E))
-
-/* The values used above are in sdata.h and types.h,
- check for consistency if the check below fails. */
-
-#if Are_The_Constants_Incompatible
-#include "Error: const.h and types.h disagree"
-#endif
-
-/* These are the only entries in Registers[] needed by the microcode.
- All other entries are used only by the compiled code interface. */
-
-#define REGBLOCK_MEMTOP 0
-#define REGBLOCK_STACKGUARD 1
-#define REGBLOCK_VAL 2
-#define REGBLOCK_ENV 3
-#define REGBLOCK_TEMP 4
-#define REGBLOCK_EXPR 5
-#define REGBLOCK_RETURN 6
-#define REGBLOCK_MINIMUM_LENGTH 7
-\f
-/* Codes specifying how to start scheme at boot time. */
-
-#define BOOT_FASLOAD 0
-#define BOOT_LOAD_BAND 1
-#define BOOT_GET_WORK 2
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.24 1987/04/16 02:20:30 jinx Rel $
-
- This file contains code for the Garbage Collection daemons.
- There are currently two daemons, one for closing files which
- have disappeared due to GC, the other for supporting object
- hash tables where entries disappear when the corresponding
- object is released due to GC.
-
- Both of these daemons should be written in Scheme, but since the
- interpreter conses while executing Scheme programs, they are
- unsafe. The Scheme versions actually exist, but are commented out
- of the appropriate runtime system sources.
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* (CLOSE-LOST-OPEN-FILES file-list)
- file-list is an assq-like list where the associations are weak
- pairs rather than normal pairs. This primitive destructively
- removes those weak pairs whose cars are #F, and closes the
- corresponding file descriptor contained in the cdrs. See io.scm in
- the runtime system for a longer description.
-*/
-
-Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES", 0xC7)
-{
- extern Boolean OS_file_close();
- fast Pointer *Smash, Cell, Weak_Cell, Value;
- long channel_number;
- Primitive_1_Arg();
-
- Value = TRUTH;
-
- for (Smash = Nth_Vector_Loc(Arg1, CONS_CDR), Cell = *Smash;
- Cell != NIL;
- Cell = *Smash)
- {
- Weak_Cell = Fast_Vector_Ref(Cell, CONS_CAR);
- if (Fast_Vector_Ref(Weak_Cell, CONS_CAR) == NIL)
- {
- channel_number = Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR));
- if (!OS_file_close (Channels[channel_number]))
- Value = NIL;
- Channels[channel_number] = NULL;
- *Smash = Fast_Vector_Ref(Cell, CONS_CDR);
- }
- else
- Smash = Nth_Vector_Loc(Cell, CONS_CDR);
- }
- return Value;
-}
-\f
-/* Utilities for the rehash daemon below */
-
-/* This runs with GC locked, being part of a GC daemon.
- It is also the case that the storage needed by this daemon is
- available, since it was all reclaimed by the immediately preceeding
- garbage collection, and at most that much is allocated now.
- Therefore, there is no gc check here.
-*/
-
-void
-rehash_pair(pair, hash_table, table_size)
-Pointer pair, hash_table;
-long table_size;
-{ long object_datum, hash_address;
- Pointer *new_pair;
-
- object_datum = Datum(Fast_Vector_Ref(pair, CONS_CAR));
- hash_address = 2+(object_datum % table_size);
- new_pair = Free;
- *Free++ = Make_New_Pointer(TC_LIST, pair);
- *Free++ = Fast_Vector_Ref(hash_table, hash_address);
- Fast_Vector_Set(hash_table,
- hash_address,
- Make_Pointer(TC_LIST, new_pair));
- return;
-}
-
-void
-rehash_bucket(bucket, hash_table, table_size)
-Pointer *bucket, hash_table;
-long table_size;
-{ fast Pointer weak_pair;
- while (*bucket != NIL)
- { weak_pair = Fast_Vector_Ref(*bucket, CONS_CAR);
- if (Fast_Vector_Ref(weak_pair, CONS_CAR) != NIL)
- { rehash_pair(weak_pair, hash_table, table_size);
- }
- bucket = Nth_Vector_Loc(*bucket, CONS_CDR);
- }
- return;
-}
-
-void
-splice_and_rehash_bucket(bucket, hash_table, table_size)
-Pointer *bucket, hash_table;
-long table_size;
-{ fast Pointer weak_pair;
- while (*bucket != NIL)
- { weak_pair = Fast_Vector_Ref(*bucket, CONS_CAR);
- if (Fast_Vector_Ref(weak_pair, CONS_CAR) != NIL)
- { rehash_pair(weak_pair, hash_table, table_size);
- bucket = Nth_Vector_Loc(*bucket, CONS_CDR);
- }
- else
- { *bucket = Fast_Vector_Ref(*bucket, CONS_CDR);
- }
- }
- return;
-}
-\f
-/* (REHASH unhash-table hash-table)
- Cleans up and recomputes hash-table from the valid information in
- unhash-table after a garbage collection.
- See hash.scm in the runtime system for a description.
-*/
-
-Built_In_Primitive(Prim_Rehash, 2, "REHASH", 0x5C)
-{
- long table_size, counter;
- Pointer *bucket;
- Primitive_2_Args();
-
- table_size = Vector_Length(Arg1);
-
- /* First cleanup the hash table */
- for (counter = table_size, bucket = Nth_Vector_Loc(Arg2, 2);
- --counter >= 0;)
- *bucket++ = NIL;
-
- /* Now rehash all the entries from the unhash table and maybe splice
- the buckets. */
-
- for (counter = table_size, bucket = Nth_Vector_Loc(Arg1, 1);
- --counter >= 0;
- bucket += 1)
- { if (Fast_Vector_Ref(*bucket, CONS_CAR) == TRUTH)
- splice_and_rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size);
- else
- rehash_bucket(Nth_Vector_Loc(*bucket, CONS_CDR), Arg2, table_size);
- }
-
- return TRUTH;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.24 1987/04/16 02:20:42 jinx Rel $
- *
- * Utilities to help with debugging
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "trap.h"
-#include "lookup.h"
-\f
-void Show_Pure()
-{ Pointer *Obj_Address;
- long Pure_Size, Total_Size;
-
- Obj_Address = Constant_Space;
- while (true)
- { if (Obj_Address > Free_Constant)
- { printf("Past end of area.\n");
- return;
- }
- if (Obj_Address == Free_Constant)
- { printf("Done.\n");
- return;
- }
- Pure_Size = Get_Integer(*Obj_Address);
- Total_Size = Get_Integer(Obj_Address[1]);
- printf("0x%x: pure=0x%x, total=0x%x\n",
- Obj_Address, Pure_Size, Total_Size);
- if (Type_Code(*Obj_Address) != TC_MANIFEST_SPECIAL_NM_VECTOR)
- { printf("Missing initial SNMV.\n");
- return;
- }
- if (Type_Code(Obj_Address[1]) != PURE_PART)
- printf("Missing subsequent pure header.\n");
- if (Type_Code(Obj_Address[Pure_Size-1]) !=
- TC_MANIFEST_SPECIAL_NM_VECTOR)
- { printf("Missing internal SNMV.\n");
- return;
- }
- if (Type_Code(Obj_Address[Pure_Size]) != CONSTANT_PART)
- { printf("Missing constant header.\n");
- return;
- }
- if (Get_Integer(Obj_Address[Pure_Size]) != Pure_Size)
- printf("Pure size mismatch 0x%x.\n",
- Get_Integer(Obj_Address[Pure_Size]));
- if (Type_Code(Obj_Address[Total_Size-1]) !=
- TC_MANIFEST_SPECIAL_NM_VECTOR)
- { printf("Missing ending SNMV.\n");
- return;
- }
- if (Type_Code(Obj_Address[Total_Size]) != END_OF_BLOCK)
- { printf("Missing ending header.\n");
- return;
- }
- if (Get_Integer(Obj_Address[Total_Size]) != Total_Size)
- printf("Total size mismatch 0x%x.\n",
- Get_Integer(Obj_Address[Total_Size]));
- Obj_Address += Total_Size+1;
-#ifdef FLOATING_ALIGNMENT
- while (*Obj_Address == Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0))
- Obj_Address += 1;
-#endif
- }
-}
-\f
-void
-Show_Env(The_Env)
- Pointer The_Env;
-{
- Pointer *name_ptr, procedure, *value_ptr, extension;
- long count, i;
-
- procedure = Vector_Ref(The_Env, ENVIRONMENT_FUNCTION);
- value_ptr = Nth_Vector_Loc(The_Env, ENVIRONMENT_FIRST_ARG);
-
- if (Type_Code(procedure) == AUX_LIST_TYPE)
- {
- extension = procedure;
- procedure = Fast_Vector_Ref(extension, ENV_EXTENSION_PROCEDURE);
- }
- else
- extension = NIL;
-
- if ((Type_Code(procedure) != TC_PROCEDURE) &&
- (Type_Code(procedure) != TC_EXTENDED_PROCEDURE))
- {
- printf("Not created by a procedure");
- return;
- }
- name_ptr = Nth_Vector_Loc(procedure, PROCEDURE_LAMBDA_EXPR);
- name_ptr = Nth_Vector_Loc(*name_ptr, LAMBDA_FORMALS);
- count = Vector_Length(*name_ptr) - 1;
-
- name_ptr = Nth_Vector_Loc(*name_ptr, 2);
- for (i = 0; i < count; i++)
- {
- Print_Expression(*name_ptr++, "Name ");
- Print_Expression(*value_ptr++, " Value ");
- printf("\n");
- }
- if (extension != NIL)
- {
- printf("Auxilliary Variables\n");
- count = Get_Integer(Vector_Ref(extension, AUX_LIST_COUNT));
- for (i = 0, name_ptr = Nth_Vector_Loc(extension, AUX_LIST_FIRST);
- i < count;
- i++, name_ptr++)
- {
- Print_Expression(Vector_Ref(*name_ptr, CONS_CAR),
- "Name ");
- Print_Expression(Vector_Ref(*name_ptr, CONS_CAR),
- " Value ");
- printf("\n");
- }
- }
-}
-\f
-List_Print(Expr)
-Pointer Expr;
-{ int Count;
- Count = 0;
- printf("(");
- while (((Type_Code(Expr) == TC_LIST) ||
- (Type_Code(Expr) == TC_WEAK_CONS))
- && Count < MAX_LIST_PRINT)
- { Print_Expression(Vector_Ref(Expr, CONS_CAR),
- (Type_Code(Expr)==TC_LIST) ? "" : "{weak}");
- Expr = Vector_Ref(Expr, CONS_CDR);
- if (Type_Code(Expr) != TC_NULL) printf(" ");
- Count += 1;
- }
- if (Type_Code(Expr) != TC_NULL)
- { if (Count==MAX_LIST_PRINT) printf("...");
- else
- { printf(". ");
- Print_Expression(Expr, "");
- }
- }
- printf(")");
-}
-\f
-long Print_Return_Name(Ptr)
-Pointer Ptr;
-{ long index = Get_Integer(Ptr);
- char *name;
- if ((index <= MAX_RETURN) &&
- ((name = Return_Names[index]) != ((char *) NULL)))
- printf("%s", name);
- else
- printf("[0x%x]", index);
-}
-
-void Print_Return(String)
-char *String;
-{ printf("%s: ", String);
- Print_Return_Name(Fetch_Return());
- CRLF();
-}
-\f
-extern Boolean Prt_PName();
-
-void Print_Expression(Expr, String)
-char *String;
-Pointer Expr;
-{ if (String[0] != 0) printf("%s: ", String);
- Do_Printing(Expr, true);
-}
-
-Do_Printing(Expr, Detailed)
-Pointer Expr;
-Boolean Detailed;
-{ long Temp_Address;
- Boolean Return_After_Print;
- Temp_Address = Get_Integer(Expr);
- Return_After_Print = false;
- switch(Type_Code(Expr))
- { case TC_ACCESS:
- printf("[ACCESS (");
- Expr = Vector_Ref(Expr, ACCESS_NAME);
- goto SPrint;
-
- case TC_ASSIGNMENT:
- printf("[SET! (");
- Expr = Vector_Ref(Vector_Ref(Expr, ASSIGN_NAME),
- VARIABLE_SYMBOL);
- goto SPrint;
-
- case TC_CHARACTER_STRING:
- { long Length, i;
- char *Next, This;
- printf("\"");
- Length = Get_Integer(Vector_Ref(Expr, STRING_LENGTH));
- Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS);
- for (i=0; i < Length; i++)
- { This = *Next++;
- printf((This < ' ') || (This > '|') ? "\\%03o" : "%c",
- This);
- }
- printf("\"");
- return;
- }
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_DEFINITION:
- printf("[DEFINE (");
- Expr = Vector_Ref(Expr, DEFINE_NAME);
- goto SPrint;
-
- case TC_FIXNUM:
- { long A;
- Sign_Extend(Expr, A);
- printf("%d", A);
- return;
- }
-
- case TC_BIG_FLONUM: printf("%f", Get_Float(Expr)); return;
-
- case TC_WEAK_CONS:
- case TC_LIST: List_Print(Expr); return;
-
- case TC_NULL:
- if (Temp_Address==0)
- { printf("()");
- return;
- }
- printf("[NULL");
- break;
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_UNINTERNED_SYMBOL:
- printf("[UNINTERNED_SYMBOL ("); goto SPrint;
-
- case TC_INTERNED_SYMBOL:
- { Pointer Name;
- char *Next_Char;
- long Length, i;
- Return_After_Print = true;
-SPrint:
- Name = Vector_Ref(Expr, SYMBOL_NAME);
- Length = Get_Integer(Vector_Ref(Name, STRING_LENGTH));
- Next_Char = (char *) Nth_Vector_Loc(Name, STRING_CHARS);
- for (i=0; i < Length; i++)
- printf("%c", *Next_Char++);
- if (Return_After_Print) return;
- printf(")");
- break;
- }
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_VARIABLE:
- if (Detailed) printf("[VARIABLE (");
- Expr = Vector_Ref(Expr, VARIABLE_SYMBOL);
- if (!Detailed) Return_After_Print = true;
- goto SPrint;
-
- case TC_BIG_FIXNUM: printf("[BIG_FIXNUM"); break;
- case TC_BROKEN_HEART: printf("[BROKEN_HEART"); break;
- case TC_CHARACTER: printf("[CHARACTER"); break;
- case TC_COMBINATION:
- printf("[COMBINATION (%d args) 0x%x]",
- Vector_Length(Expr)-1, Temp_Address);
- if (Detailed)
- { printf(" (");
- Do_Printing(Vector_Ref(Expr, COMB_FN_SLOT), false);
- printf(" ...)");
- }
- return;
- case TC_COMBINATION_1:
- printf("[COMBINATION_1 0x%x]", Temp_Address);
- if (Detailed)
- { printf(" (");
- Do_Printing(Vector_Ref(Expr, COMB_1_FN), false);
- printf(", ");
- Do_Printing(Vector_Ref(Expr, COMB_1_ARG_1), false);
- printf(")");
- }
- return;
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_COMBINATION_2:
- printf("[COMBINATION_2 0x%x]", Temp_Address);
- if (Detailed)
- { printf(" (");
- Do_Printing(Vector_Ref(Expr, COMB_2_FN), false);
- printf(", ");
- Do_Printing(Vector_Ref(Expr, COMB_2_ARG_1), false);
- printf(", ");
- Do_Printing(Vector_Ref(Expr, COMB_2_ARG_2), false);
- printf(")");
- }
- return;
- case TC_CELL: printf("[CELL"); break;
- case TC_COMMENT: printf("[COMMENT"); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED_EXPRESSION"); break;
- case TC_COMPILED_PROCEDURE:
- printf("[COMPILED_PROCEDURE"); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL"); break;
- case TC_CONTROL_POINT: printf("[CONTROL_POINT"); break;
- case TC_DELAY: printf("[DELAY"); break;
- case TC_DELAYED: printf("[DELAYED"); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION"); break;
- case TC_ENVIRONMENT:
- {
- Pointer procedure;
-
- printf("[ENVIRONMENT 0x%x]", Temp_Address);
- printf(" (from ");
- procedure = Vector_Ref(Expr, ENVIRONMENT_FUNCTION);
- if (Type_Code(procedure) == TC_QUAD)
- procedure = Vector_Ref(procedure, ENV_EXTENSION_PROCEDURE);
- Do_Printing(procedure, false);
- printf(")");
- return;
- }
- case TC_EXTENDED_LAMBDA:
- if (Detailed) printf("[EXTENDED_LAMBDA (");
- Do_Printing(
- Vector_Ref(
- Vector_Ref(Expr, ELAMBDA_NAMES),
- 1), false);
- if (Detailed) printf(") 0x%x", Temp_Address);
- return;
- case TC_EXTENDED_PROCEDURE:
- if (Detailed) printf("[EXTENDED_PROCEDURE (");
- Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
- if (Detailed) printf(") 0x%x]", Temp_Address);
- break;
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_FUTURE: printf("[FUTURE"); break;
- case TC_HUNK3: printf("[TRIPLE"); break;
- case TC_IN_PACKAGE: printf("[IN_PACKAGE"); break;
- case TC_LAMBDA:
- if (Detailed) printf("[LAMBDA (");
- Do_Printing(
- Vector_Ref(
- Vector_Ref(Expr, LAMBDA_FORMALS),
- 1), false);
- if (Detailed) printf(") 0x%x]", Temp_Address);
- return;
- case TC_LEXPR: printf("[LEXPR"); break;
- case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST_NM_VECTOR"); break;
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- printf("[MANIFEST_SPECIAL_NM_VECTOR"); break;
- case TC_NON_MARKED_VECTOR: printf("[NON_MARKED_VECTOR"); break;
- case TC_PCOMB0: printf("[PCOMB0"); break;
- case TC_PCOMB1: printf("[PCOMB1"); break;
- case TC_PCOMB2: printf("[PCOMB2"); break;
- case TC_PCOMB3: printf("[PCOMB3"); break;
- case TC_PRIMITIVE:
- printf("[PRIMITIVE "); Prt_PName(Temp_Address);
- printf("]"); return;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE_EXTERNAL"); break;
- case TC_PROCEDURE:
- if (Detailed) printf("[PROCEDURE (");
- Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
- if (Detailed) printf(") 0x%x]", Temp_Address);
- return;
-
-/* Do_Printing continues on the next page */
-\f
-/* Do_Printing, continued */
-
- case TC_QUAD: printf("[QUAD"); break;
- case TC_REFERENCE_TRAP:
- {
- printf("[REFERENCE-TRAP");
- if (Datum(Expr) <= TRAP_MAX_IMMEDIATE)
- break;
- Print_Expression(Vector_Ref(Expr, TRAP_TAG), " tag");
- Print_Expression(Vector_Ref(Expr, TRAP_EXTRA), " extra");
- printf("]");
- return;
- }
- case TC_RETURN_CODE:
- printf("[RETURN_CODE ");
- Print_Return_Name(Expr);
- printf("]");
- return;
- case TC_SCODE_QUOTE: printf("[SCODE_QUOTE"); break;
- case TC_SEQUENCE_2: printf("[SEQUENCE_2"); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE_3"); break;
- case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break;
- case TC_TRUE:
- if (Temp_Address == 0)
- { printf("#!true");
- return;
- }
- printf("[TRUE");
- break;
- case TC_VECTOR: printf("[VECTOR"); break;
- case TC_VECTOR_16B: printf("[VECTOR_16B"); break;
- case TC_VECTOR_1B: printf("[VECTOR_1B"); break;
- default: printf("[0x%x", Type_Code(Expr));
- }
- printf(" 0x%x]", Temp_Address);
-}
-\f
-Boolean
-Print_One_Continuation_Frame(Temp)
- Pointer Temp;
-{
- Pointer Expr;
-
- Print_Expression(Temp, "Return code");
- CRLF();
- Expr = Pop();
- Print_Expression(Expr, "Expression");
- printf("\n");
- if ((Datum(Temp) == RC_END_OF_COMPUTATION) ||
- (Datum(Temp) == RC_HALT)) return true;
- if (Datum(Temp) == RC_JOIN_STACKLETS)
- Stack_Pointer = Previous_Stack_Pointer(Expr);
- return false;
-}
-\f
-/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
- stack; (b) Save_Cont pushes the expression first. */
-
-void
-Back_Trace()
-{
- Pointer Temp, *Old_Stack;
-
- Back_Trace_Entry_Hook();
- Old_Stack = Stack_Pointer;
- while (true)
- { if (Return_Hook_Address == &Top_Of_Stack())
- { Temp = Pop();
- if (Temp != Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
- printf("\n--> Return trap is missing here <--\n");
- else
- { printf("\n[Return trap found here as expected]\n");
- Temp = Old_Return_Code;
- }
- }
- else Temp = Pop();
- if (Type_Code(Temp) == TC_RETURN_CODE)
- { if (Print_One_Continuation_Frame(Temp))
- break;
- }
- else
- { Print_Expression(Temp, " ...");
- if (Type_Code(Temp) == TC_MANIFEST_NM_VECTOR)
- { Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
- printf(" (skipping)");
- }
- printf("\n");
- }
- }
- Stack_Pointer = Old_Stack;
- Back_Trace_Exit_Hook();
-}
-
-void
-Print_Stack(SP)
- Pointer *SP;
-{
- Pointer *Saved_SP;
-
- Saved_SP = Stack_Pointer;
- Stack_Pointer = SP;
- Back_Trace();
- Stack_Pointer = Saved_SP;
- return;
-}
-\f
-Boolean
-Prt_PName(Number)
- long Number;
-{
- extern char *primitive_to_name();
- char *name;
-
- name = primitive_to_name(Number);
- if (name == ((char *) NULL))
- {
- printf("Unknown primitive 0x%08x", Number);
- return false;
- }
- else
- {
- printf("%s", name);
- return true;
- }
-}
-
-void Print_Primitive(Number)
- long Number;
-{
-
- extern long primitive_to_arity();
- char buffer1[40], buffer2[40];
- int NArgs, i;
-
- printf("Primitive: ");
- if (Prt_PName(Number))
- NArgs = primitive_to_arity(Number);
- else
- NArgs = 3; /* Unknown primitive */
- printf("\n");
-
- for (i = 0; i < NArgs; i++)
- {
- sprintf(buffer1, "Stack_Ref(%d)", i);
- sprintf(buffer2, "...Arg %d", (i + 1));
- Print_Expression(buffer1, buffer2);
- printf("\n");
- }
-}
-\f
-Debug_Printer(Expr)
-Pointer Expr;
-{ Print_Expression(Expr, "");
- putchar('\n');
-}
-
-/* (DEBUGGING-PRINTER OBJECT)
- A cheap, built-in printer intended for debugging the
- interpreter.
-*/
-Built_In_Primitive(Prim_Temp_Printer, 1, "DEBUGGING-PRINTER", 0xB2)
-{
- Primitive_1_Arg();
-
- Debug_Printer(Arg1);
- return TRUTH;
-}
-\f
-/* Code for interactively setting and clearing the interpreter
- debugging flags. Invoked via the "D" command to the ^B
- handler or during each FASLOAD.
-*/
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define D_EVAL 0
-#define D_HEX_INPUT 1
-#define D_FILE_LOAD 2
-#define D_RELOC 3
-#define D_INTERN 4
-#define D_CONT 5
-#define D_PRIMITIVE 6
-#define D_LOOKUP 7
-#define D_DEFINE 8
-#define D_GC 9
-#define D_UPGRADE 10
-#define D_DUMP 11
-#define D_TRACE_ON_ERROR 12
-#define D_PER_FILE 13
-#define D_BIGNUM 14
-#define D_FLUIDS 15
-#define LAST_NORMAL_SWITCH 15
-
-Boolean *Find_Flag(Num)
-int Num;
-{ switch (Num)
- { case D_EVAL: return &Eval_Debug;
- case D_HEX_INPUT: return &Hex_Input_Debug;
- case D_FILE_LOAD: return &File_Load_Debug;
- case D_RELOC: return &Reloc_Debug;
- case D_INTERN: return &Intern_Debug;
- case D_CONT: return &Cont_Debug;
- case D_PRIMITIVE: return &Primitive_Debug;
- case D_LOOKUP: return &Lookup_Debug ;
- case D_DEFINE: return &Define_Debug;
- case D_GC: return &GC_Debug;
- case D_UPGRADE: return &Upgrade_Debug;
- case D_DUMP: return &Dump_Debug;
- case D_TRACE_ON_ERROR: return &Trace_On_Error;
- case D_PER_FILE: return &Per_File;
- case D_BIGNUM: return &Bignum_Debug;
- case D_FLUIDS: return &Fluids_Debug;
- More_Debug_Flag_Cases();
- default: show_flags(true); return NULL;
- }
-}
-\f
-set_flag(Num, Value)
-int Num;
-Boolean Value;
-{ Boolean *Flag = Find_Flag(Num);
- if (Flag != NULL) *Flag = Value;
- Set_Flag_Hook();
-}
-
-char *Flag_Name(Num)
-int Num;
-{ switch(Num)
- { case D_EVAL: return "Eval_Debug";
- case D_HEX_INPUT: return "Hex_Input_Debug";
- case D_FILE_LOAD: return "File_Load_Debug";
- case D_RELOC: return "Reloc_Debug";
- case D_INTERN: return "Intern_Debug";
- case D_CONT: return "Cont_Debug";
- case D_PRIMITIVE: return "Primitive_Debug";
- case D_LOOKUP: return "Lookup_Debug";
- case D_DEFINE: return "Define_Debug";
- case D_GC: return "GC_Debug";
- case D_UPGRADE: return "Upgrade_Debug";
- case D_DUMP: return "Dump_Debug";
- case D_TRACE_ON_ERROR: return "Trace_On_Error";
- case D_PER_FILE: return "Per_File";
- case D_BIGNUM: return "Bignum_Debug";
- case D_FLUIDS: return "Fluids_Debug";
- More_Debug_Flag_Names();
- default: return "Unknown Debug Flag";
- }
-}
-\f
-show_flags(All)
-Boolean All;
-{ int i;
- for (i=0; i <= LAST_SWITCH; i++)
- { Boolean Value = *Find_Flag(i);
- if (All || Value)
- { printf("Flag %d (%s) is %s.\n",
- i, Flag_Name(i), Value? "set" : "clear");
- }
- }
-}
-
-extern int OS_tty_tyi();
-
-#define C_STRING_LENGTH 256
-\f
-void Handle_Debug_Flags()
-{ char c, input_string[C_STRING_LENGTH];
- int Which, free;
- Boolean interrupted;
- show_flags(false);
- while (true)
- { interrupted = false;
- printf("Clear<number>, Set<number>, Done, ?, or Halt: ");
- OS_Flush_Output_Buffer();
-
- /* Considerably haired up to go through standard (safe) interface */
-
- c = (char) OS_tty_tyi(false, &interrupted);
- if (interrupted) return;
- for (free = 0; free < C_STRING_LENGTH; free++)
- { input_string[free] = OS_tty_tyi(false, &interrupted);
- if (interrupted) return;
- if (input_string[free] == '\n')
- { input_string[free] = '\0';
- break;
- }
- }
-
-/* Handle_Debug_Flags continues on the next page */
-\f
-/* Handle_Debug_Flags, continued */
-
- switch (c)
- { case 'c':
- case 'C': Which=debug_getdec(input_string);
- set_flag(Which, false);
- break;
- case 's':
- case 'S': Which=debug_getdec(input_string);
- set_flag(Which, true);
- break;
- case 'd':
- case 'D': return;
- case 'h':
- case 'H': Microcode_Termination(TERM_HALT);
-
- case '?':
- default : show_flags(true);
- break;
- }
- }
-}
-
-int normal_debug_getdec(str)
-{ int Result;
- sscanf(str, "%d", &Result);
- return Result;
-}
-
-#else /* ENABLE_DEBUGGING_TOOLS */
-void Handle_Debug_Flags()
-{ fprintf(stderr, "Not a debugging version. No flags to handle.\n");
- return;
-}
-#endif /* not ENABLE_DEBUGGING_TOOLS */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.22 1987/04/16 02:20:58 jinx Exp $
- *
- * This file contains default definitions for some hooks which
- * various machines require. These machines define these hooks
- * in CONFIG.H and this file defines them only if they remain
- * undefined.
- *
- */
-\f
-/* Compiler bug fixes. */
-
-#ifndef And2
-#define And2(x, y) ((x) && (y))
-#define And3(x, y, z) ((x) && (y) && (z))
-#define Or2(x, y) ((x) || (y))
-#define Or3(x, y, z) ((x) || (y) || (z))
-#endif
-
-#ifndef Fetch
-/* These definitions allow a true multi-processor with shared memory
- but no atomic longword operations (Butterfly and Concert,
- for example) to supply their own atomic operators in config.h.
-*/
-#define Fetch(P) (P)
-#define Store(P, S) (P) = (S)
-#endif
-
-#ifndef Get_Fixed_Obj_Slot
-#define Get_Fixed_Obj_Slot(N) Fast_User_Vector_Ref(Fixed_Objects, N)
-#define Set_Fixed_Obj_Slot(N,S) Fast_User_Vector_Set(Fixed_Objects, N, S)
-#define Update_FObj_Slot(N, S) Set_Fixed_Obj_Slot(N, S)
-#define Declare_Fixed_Objects() Pointer Fixed_Objects;
-#define Valid_Fixed_Obj_Vector() \
- (Type_Code(Fixed_Objects) == TC_VECTOR)
-#define Save_Fixed_Obj(Save_FO) \
- Save_FO = Fixed_Objects; \
- Fixed_Objects = NIL;
-#define Restore_Fixed_Obj(Save_FO) \
- Fixed_Objects = Save_FO
-#endif
-
-
-/* Atomic swapping hook. Used extensively. */
-
-#ifndef Swap_Pointers
-extern Pointer Swap_Temp;
-#define Swap_Pointers(P, S) \
-(Swap_Temp = *(P), *(P) = (S), Swap_Temp)
-#endif
-\f
-#ifndef Set_Pure_Top
-#ifndef USE_STACKLETS
-#define Set_Pure_Top() \
- Align_Float(Free_Constant); \
- Set_Stack_Guard(Free_Constant+STACK_GUARD_SIZE)
-#define Test_Pure_Space_Top(New_Top) \
- ((New_Top+STACK_GUARD_SIZE) <= Stack_Pointer)
-#define Absolute_Stack_Base Free_Constant
-
-#ifndef Initialize_Stack
-#define Initialize_Stack() \
- Stack_Top = Highest_Allocated_Address; \
- Stack_Pointer = Stack_Top; \
- Set_Stack_Guard(Free_Constant + STACK_GUARD_SIZE)
-#endif
-
-#else /* Stacklets in use */
-
-#define Set_Pure_Top() Align_Float(Free_Constant)
-#define Test_Pure_Space_Top(New_Top) \
- (New_Top <= Highest_Allocated_Address)
-#endif
-#endif
-\f
-/* Character IO hooks. Used extensively. */
-
-#ifndef OS_Put_C
-#define OS_Put_C putc
-#endif
-
-#ifndef OS_Get_C
-#define OS_Get_C getc
-#endif
-
-/* Used in BOOT.C */
-
-#ifndef term_type
-#define term_type void
-#endif
-
-#ifndef Command_Line_Hook
-#define Command_Line_Hook()
-#endif
-
-#ifndef Exit_Scheme_Declarations
-#define Exit_Scheme_Declarations
-#endif
-
-#ifndef Init_Exit_Scheme
-#define Init_Exit_Scheme()
-#endif
-
-#ifndef Exit_Scheme
-#define Exit_Scheme exit
-#endif
-\f
-/* Used in various places. */
-
-#ifndef Init_Fixed_Objects
-#define Init_Fixed_Objects() \
- Default_Init_Fixed_Objects(Fixed_Objects)
-#endif
-
-#ifndef Set_Fixed_Obj_Hook
-#define Set_Fixed_Obj_Hook(New_Vector) \
- Fixed_Objects = New_Vector
-#endif
-
-#ifndef Entry_Hook
-#define Entry_Hook()
-#endif
-
-#ifndef Exit_Hook
-#define Exit_Hook()
-#endif
-
-#ifndef Sys_Clock
-#define Sys_Clock() System_Clock()
-#endif
-\f
-/* Used in DEBUG.C */
-
-#ifndef Back_Trace_Entry_Hook
-#define Back_Trace_Entry_Hook()
-#endif
-
-#ifndef Back_Trace_Exit_Hook
-#define Back_Trace_Exit_Hook()
-#endif
-
-#ifndef More_Debug_Flag_Cases
-#define More_Debug_Flag_Cases()
-#endif
-
-#ifndef Set_Flag_Hook
-#define Set_Flag_Hook()
-#endif
-
-#ifndef More_Debug_Flag_Names
-#define More_Debug_Flag_Names()
-#endif
-
-#ifndef LAST_SWITCH
-#define LAST_SWITCH LAST_NORMAL_SWITCH
-#endif
-
-#ifndef debug_getdec
-#define debug_getdec normal_debug_getdec
-#endif
-\f
-/* Used in EXTERN.H */
-
-#ifndef More_Debug_Flag_Externs
-#define More_Debug_Flag_Externs()
-#endif
-
-/* Used in FASDUMP.C */
-
-#ifndef Band_Dump_Permitted
-#define Band_Dump_Permitted()
-#endif
-
-#ifndef Band_Load_Hook
-#define Band_Load_Hook()
-#endif
-
-#ifndef Fasdump_Exit_Hook
-#define Fasdump_Exit_Hook()
-#endif
-
-#ifndef Fasdump_Free_Calc
-#define Fasdump_Free_Calc(NewFree, NewMemtop, ignored) \
- NewFree = Unused_Heap; \
- NewMemTop = Unused_Heap_Top
-#endif
-
-/* Used in FASLOAD.C */
-
-#ifndef Open_File_Hook
-#define Open_File_Hook(ignore)
-#endif
-
-#ifndef Close_File_Hook
-#define Close_File_Hook()
-#endif
-
-/* Used in FLONUM.H and GENERIC.C */
-
-#ifndef double_into_fixnum
-#define double_into_fixnum(what, target) \
- target = Make_Non_Pointer(TC_FIXNUM, ((long) (what)))
-#endif
-\f
-/* Used in INTERPRET.C */
-
-/* Primitive calling code. */
-
-#ifndef ENABLE_DEBUGGING_TOOLS
-#define Apply_Primitive(N) Internal_Apply_Primitive(N)
-#else
-extern Pointer Apply_Primitive();
-#endif
-
-#ifndef Metering_Apply_Primitive
-#define Metering_Apply_Primitive(Loc, N) \
-Loc = Apply_Primitive(N)
-#endif
-
-#ifndef Eval_Ucode_Hook()
-#define Eval_Ucode_Hook()
-#endif
-
-#ifndef Pop_Return_Ucode_Hook()
-#define Pop_Return_Ucode_Hook()
-#endif
-
-#ifndef Apply_Ucode_Hook()
-#define Apply_Ucode_Hook()
-#endif
-
-#ifndef End_GC_Hook
-#define End_GC_Hook()
-#endif
-\f
-/* Used in STORAGE.C */
-
-#ifndef More_Debug_Flag_Allocs
-#define More_Debug_Flag_Allocs()
-#endif
-
-/* Used in UTILS.C */
-
-#ifndef Global_Interrupt_Hook
-#define Global_Interrupt_Hook()
-#endif
-
-#ifndef Error_Exit_Hook
-#define Error_Exit_Hook()
-#endif
-
-/* Used in LOOKUP.C */
-
-/* Permit caching of incrementally defined variables */
-#ifndef Allow_Aux_Compilation
-#define Allow_Aux_Compilation true
-#endif
-
-/* This is how we support future numbering for external metering */
-#ifndef New_Future_Number
-#define New_Future_Number() NIL
-#else
-Pointer Get_New_Future_Number();
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.24 1987/04/16 02:21:08 jinx Exp $
- *
- * This file contains a primitive to dump an executable version of Scheme.
- * It uses unexec.c from GNU Emacs.
- * Look at unexec.c for more information.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-#ifndef unix
-#include "Error: dumpworld.c does not work on non-unix machines."
-#endif
-
-/* Compatibility definitions for GNU Emacs's unexec.c.
- Taken from the various m-*.h and s-*.h files for GNU Emacs.
-*/
-
-#ifdef vax
-#define UNEXEC_AVAILABLE
-#endif
-
-#ifdef hp9000s200
-#define UNEXEC_AVAILABLE
-#define ADJUST_EXEC_HEADER \
- hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ? \
- NEWMAGIC : ohdr.a_magic);
-
-#endif
-
-#ifdef sun3
-#define UNEXEC_AVAILABLE
-#define SEGMENT_MASK (SEGSIZ - 1)
-#define A_TEXT_OFFSET(HDR) sizeof (HDR)
-#define TEXT_START (PAGSIZ + (sizeof(struct exec)))
-#endif
-
-/* I haven't tried any below this point. */
-
-#if defined(umax)
-#define UNEXEC_AVAILABLE
-#define HAVE_GETPAGESIZE
-#define COFF
-#define UMAX
-#define SECTION_ALIGNMENT pagemask
-#define SEGMENT_MASK (64 * 1024 - 1)
-#endif
-
-#ifdef celerity
-#define UNEXEC_AVAILABLE
-#endif
-
-#ifdef sun2
-#define UNEXEC_AVAILABLE
-#define SEGMENT_MASK (SEGSIZ - 1)
-#endif
-\f
-#ifndef UNEXEC_AVAILABLE
-#include "Error: dumpworld.c only works on a few machines."
-#endif
-
-#ifndef TEXT_START
-#define TEXT_START 0
-#endif
-
-#ifndef SEGMENT_MASK
-#define DATA_START (&etext)
-#else
-#define DATA_START \
-(((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1))
-#endif
-
-#ifdef hpux
-#define USG
-#define HPUX
-#endif
-\f
-/* More compatibility definitions for unexec. */
-
-extern int end, etext, edata;
-char *start_of_text(), *start_of_data();
-void bzero();
-
-#include "unexec.c"
-
-char
-*start_of_text()
-{
- return ((char *) TEXT_START);
-}
-
-char
-*start_of_data()
-{
- return ((char *) DATA_START);
-}
-
-void
-bzero (b, length)
- register char *b;
- register int length;
-{
- while (length-- > 0)
- *b++ = 0;
-}
-\f
-/* Making sure that IO will be alright when restored. */
-
-Boolean
-there_are_open_files()
-{
- register int i;
-
- i = FILE_CHANNELS;
- while (i > 0)
- if (Channels[--i] != NULL) return true;
- return false;
-}
-
-/* These two procedures depend on the internal structure of a
- FILE object. See /usr/include/stdio.h for details. */
-
-long
-Save_Input_Buffer()
-{
- long result;
-
- result = (stdin)->_cnt;
- (stdin)->_cnt = 0;
- return result;
-}
-
-void
-Restore_Input_Buffer(Buflen)
- fast long Buflen;
-{
- (stdin)->_cnt = Buflen;
- return;
-}
-\f
-/* The primitive visible from Scheme. */
-
-extern Boolean Was_Scheme_Dumped;
-extern unix_find_pathname();
-
-Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD")
-{
- char *fname, path_buffer[FILE_NAME_LENGTH];
- Boolean Saved_Dumped_Value, Saved_Photo_Open;
- int Result;
- long Buflen;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (there_are_open_files())
- Primitive_Error(ERR_OUT_OF_FILE_HANDLES);
-
- fname = Scheme_String_To_C_String(Arg1);
-
- /* Set up for restore */
-
- Saved_Dumped_Value = Was_Scheme_Dumped;
- Saved_Photo_Open = Photo_Open;
-
- /* IO: flushing pending output, and flushing cached input. */
-
- fflush(stdout);
- fflush(stderr);
-
- if (Photo_Open)
- {
- fflush(Photo_File_Handle);
- Photo_Open = false;
- }
-
- Buflen = Save_Input_Buffer();
-
- Was_Scheme_Dumped = true;
- Val = TRUTH;
- OS_Quit();
- Pop_Primitive_Frame(1);
-
- /* Dump! */
-
- unix_find_pathname(Saved_argv[0], path_buffer);
- Result = unexec(fname,
- path_buffer,
- ((unsigned) 0), /* default */
- ((unsigned) 0), /* default */
- ((unsigned) start_of_text())
- );
-
- /* Restore State */
-
- OS_Re_Init();
- Val = NIL;
- Was_Scheme_Dumped = Saved_Dumped_Value;
-
- /* IO: Restoring cached input for this job. */
-
- Restore_Input_Buffer(Buflen);
- Photo_Open = Saved_Photo_Open;
-
- if (Result != 0)
- {
- Push(Arg1); /* Since popped above */
- Primitive_Error(ERR_EXTERNAL_RETURN);
- }
-
- longjmp(*Back_To_Eval, PRIM_POP_RETURN);
- /*NOTREACHED*/
-}
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.22 1987/04/03 00:11:11 jinx Exp $
- *
- * This file contains common code for dumping internal format binary files.
- */
-\f
-#include "fasl.h"
-
-Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
- Constant_Count, Constant_Relocation, Prim_Exts)
-Pointer *Heap_Relocation, *Dumped_Object,
- *Constant_Relocation, *Prim_Exts;
-long Heap_Count, Constant_Count;
-{ Pointer Buffer[FASL_HEADER_LENGTH];
- long i;
-
-#ifdef DEBUG
-#ifndef Heap_In_Low_Memory
- fprintf(stderr, "\nMemory_Base = 0x%x\n", Memory_Base);
-#endif
- fprintf(stderr, "\nHeap_Relocation=0x%x, dumped as 0x%x\n",
- Heap_Relocation, Make_Pointer(TC_BROKEN_HEART, Heap_Relocation));
- fprintf(stderr, "\nDumped object=0x%x, dumped as 0x%x\n",
- Dumped_Object, Make_Pointer(TC_BROKEN_HEART, Dumped_Object));
-#endif
- Buffer[FASL_Offset_Marker] = FASL_FILE_MARKER;
- Buffer[FASL_Offset_Heap_Count] =
- Make_Non_Pointer(TC_BROKEN_HEART, Heap_Count);
- Buffer[FASL_Offset_Heap_Base] =
- Make_Pointer(TC_BROKEN_HEART, Heap_Relocation);
- Buffer[FASL_Offset_Dumped_Obj] =
- Make_Pointer(TC_BROKEN_HEART, Dumped_Object);
- Buffer[FASL_Offset_Const_Count] =
- Make_Non_Pointer(TC_BROKEN_HEART, Constant_Count);
- Buffer[FASL_Offset_Const_Base] =
- Make_Pointer(TC_BROKEN_HEART, Constant_Relocation);
- Buffer[FASL_Offset_Version] =
- Make_Version(FASL_FORMAT_VERSION,
- FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- Buffer[FASL_Offset_Stack_Top] =
-#ifdef USE_STACKLETS
- Make_Pointer(TC_BROKEN_HEART, 0); /* Nothing in stack area */
-#else
- Make_Pointer(TC_BROKEN_HEART, Stack_Top);
-#endif
- Buffer[FASL_Offset_Ext_Loc] =
- Make_Pointer(TC_BROKEN_HEART, Prim_Exts);
- for (i=FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
- Buffer[i] = NIL;
- Write_Data(FASL_HEADER_LENGTH, (char *) Buffer);
- if (Heap_Count != 0) Write_Data(Heap_Count, (char *) Heap_Relocation);
- if (Constant_Count != 0)
- Write_Data(Constant_Count, (char *) Constant_Relocation);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.24 1987/04/03 00:11:24 jinx Rel $
- *
- * Error and termination code declarations. This must correspond
- * to UTABMD.SCM
- *
- */
-\f
-/* All error and termination codes must be positive
- * to allow primitives to return either an error code
- * or a primitive flow control value (see CONST.H)
- */
-
-#define ERR_BAD_ERROR_CODE 0x00
-#define ERR_UNBOUND_VARIABLE 0x01
-#define ERR_UNASSIGNED_VARIABLE 0x02
-#define ERR_INAPPLICABLE_OBJECT 0x03
-/* #define ERR_OUT_OF_HASH_NUMBERS 0x04 */
-/* #define ERR_ENVIRONMENT_CHAIN_TOO_DEEP 0x05 */
-#define ERR_BAD_FRAME 0x06
-#define ERR_BROKEN_COMPILED_VARIABLE 0x07
-#define ERR_UNDEFINED_USER_TYPE 0x08
-#define ERR_UNDEFINED_PRIMITIVE 0x09
-#define ERR_EXTERNAL_RETURN 0x0A
-#define ERR_EXECUTE_MANIFEST_VECTOR 0x0B
-#define ERR_WRONG_NUMBER_OF_ARGUMENTS 0x0C
-#define ERR_ARG_1_WRONG_TYPE 0x0D
-#define ERR_ARG_2_WRONG_TYPE 0x0E
-#define ERR_ARG_3_WRONG_TYPE 0x0F
-#define ERR_ARG_1_BAD_RANGE 0x10
-#define ERR_ARG_2_BAD_RANGE 0x11
-#define ERR_ARG_3_BAD_RANGE 0x12
-/* #define ERR_BAD_COMBINATION 0x13 */
-/* #define ERR_FASDUMP_OVERFLOW 0x14 */
-#define ERR_BAD_INTERRUPT_CODE 0x15 /* Not generated */
-/* #define ERR_NO_ERRORS 0x16 */
-#define ERR_FASL_FILE_TOO_BIG 0x17
-#define ERR_FASL_FILE_BAD_DATA 0x18
-#define ERR_IMPURIFY_OUT_OF_SPACE 0x19
-\f
-/* The following do not exist in the 68000 version */
-#define ERR_WRITE_INTO_PURE_SPACE 0x1A
-/* #define ERR_LOSING_SPARE_HEAP 0x1B */
-/* #define ERR_NO_HASH_TABLE 0x1C */
-#define ERR_BAD_SET 0x1D
-#define ERR_ARG_1_FAILED_COERCION 0x1E
-#define ERR_ARG_2_FAILED_COERCION 0x1F
-#define ERR_OUT_OF_FILE_HANDLES 0x20
-/* #define ERR_SHELL_DIED 0x21 */
-
-/* Late additions to both 68000 and C world */
-#define ERR_ARG_4_BAD_RANGE 0x22
-#define ERR_ARG_5_BAD_RANGE 0x23
-#define ERR_ARG_6_BAD_RANGE 0x24
-#define ERR_ARG_7_BAD_RANGE 0x25
-#define ERR_ARG_8_BAD_RANGE 0x26
-#define ERR_ARG_9_BAD_RANGE 0x27
-#define ERR_ARG_10_BAD_RANGE 0x28
-#define ERR_ARG_4_WRONG_TYPE 0x29
-#define ERR_ARG_5_WRONG_TYPE 0x2A
-#define ERR_ARG_6_WRONG_TYPE 0x2B
-#define ERR_ARG_7_WRONG_TYPE 0x2C
-#define ERR_ARG_8_WRONG_TYPE 0x2D
-#define ERR_ARG_9_WRONG_TYPE 0x2E
-#define ERR_ARG_10_WRONG_TYPE 0x2F
-#define ERR_INAPPLICABLE_CONTINUATION 0x30
-#define ERR_COMPILED_CODE_ERROR 0x31
-#define ERR_FLOATING_OVERFLOW 0x32
-#define ERR_UNIMPLEMENTED_PRIMITIVE 0x33
-
-#define MAX_ERROR 0x33
-\f
-/* Termination codes: the interpreter halts on these */
-
-#define TERM_HALT 0x00
-#define TERM_DISK_RESTORE 0x01
-#define TERM_BROKEN_HEART 0x02
-#define TERM_NON_POINTER_RELOCATION 0x03
-#define TERM_BAD_ROOT 0x04
-#define TERM_NON_EXISTENT_CONTINUATION 0x05
-#define TERM_BAD_STACK 0x06
-#define TERM_STACK_OVERFLOW 0x07
-#define TERM_STACK_ALLOCATION_FAILED 0x08
-#define TERM_NO_ERROR_HANDLER 0x09
-#define TERM_NO_INTERRUPT_HANDLER 0x0A
-#define TERM_UNIMPLEMENTED_CONTINUATION 0x0B
-#define TERM_EXIT 0x0C
-#define TERM_BAD_PRIMITIVE_DURING_ERROR 0x0D
-#define TERM_EOF 0x0E
-#define TERM_BAD_PRIMITIVE 0x0F
-#define TERM_TERM_HANDLER 0x10
-#define TERM_END_OF_COMPUTATION 0x11
-#define TERM_INVALID_TYPE_CODE 0x12
-#define TERM_COMPILER_DEATH 0x13
-#define TERM_GC_OUT_OF_SPACE 0x14
-#define TERM_NO_SPACE 0x15
-#define TERM_SIGNAL 0x16
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.22 1987/04/16 02:21:18 jinx Rel $ */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* (GET-EXTERNAL-COUNTS)
- Returns a CONS of the number of external primitives defined in this
- interpreter and the number of external primitives referenced but
- not defined.
-*/
-
-Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNAL-COUNTS", 0x101)
-{
- Primitive_0_Args();
-
- *Free++ = Make_Unsigned_Fixnum(MAX_EXTERNAL_PRIMITIVE + 1);
- *Free++ = Make_Unsigned_Fixnum(NUndefined());
- return Make_Pointer(TC_LIST, Free - 2);
-}
-\f
-/* (GET-EXTERNAL-NAME n)
- Given a number, return the string for the name of the corresponding
- external primitive. An error if the number is out of range.
- External primitives start at 0.
-*/
-
-Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME", 0x102)
-{
- extern Pointer external_primitive_name();
- long Number, TC;
- Primitive_1_Arg();
-
- TC = Type_Code(Arg1);
- if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE_EXTERNAL))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Range_Check(Number, Arg1, 0, MAX_EXTERNAL_PRIMITIVE+NUndefined(),
- ERR_ARG_1_BAD_RANGE);
- if (Number <= MAX_EXTERNAL_PRIMITIVE)
- return external_primitive_name(Number);
- else return User_Vector_Ref(Undefined_Externals,
- (Number - MAX_EXTERNAL_PRIMITIVE));
-}
-\f
-/* (GET-EXTERNAL-NUMBER name intern?)
- Given a symbol (name), return the external primitive object
- corresponding to this name.
- If intern? is true, then an external object is created if one
- didn't exist before.
- If intern? is false, NIL is returned if the primitive is not
- implemented even if the name alredy exists.
- Otherwise, NIL is returned if the primitive does not exist and
- the name does not exist either.
-*/
-
-Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER", 0x103)
-{
- extern long make_external_primitive();
- Primitive_2_Args();
-
- Arg_1_Type(TC_INTERNED_SYMBOL);
- Touch_In_Primitive(Arg2, Arg2);
- return make_external_primitive(Arg1, Arg2);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.24 1987/04/16 02:21:28 jinx Exp $
- *
- * External declarations.
- *
- */
-\f
-#ifdef ENABLE_DEBUGGING_TOOLS
-
-extern Boolean Eval_Debug, Hex_Input_Debug, Cont_Debug,
- File_Load_Debug, Reloc_Debug, Intern_Debug,
- Primitive_Debug, Define_Debug, Lookup_Debug, GC_Debug,
- Upgrade_Debug, Trace_On_Error, Dump_Debug, Per_File,
- Bignum_Debug, Fluids_Debug;
-
-extern sp_record_list SP_List;
-extern void Pop_Return_Break_Point();
-extern int debug_slotno, debug_nslots, local_slotno, local_nslots,
- debug_circle[], local_circle[];
-#else
-#define Eval_Debug false
-#define Hex_Input_Debug false
-#define File_Load_Debug false
-#define Reloc_Debug false
-#define Intern_Debug false
-#define Cont_Debug false
-#define Primitive_Debug false
-#define Lookup_Debug false
-#define Define_Debug false
-#define GC_Debug false
-#define Upgrade_Debug false
-#define Trace_On_Error false
-#define Dump_Debug false
-#define Per_File false
-#define Bignum_Debug false
-#define Fluids_Debug false
-#endif
-\f
-/* The register block */
-
-extern Pointer Registers[];
-
-extern Pointer
- *Ext_History, /* History register */
- *Free, /* Next free word in heap */
- *MemTop, /* Top of heap space available */
- *Ext_Stack_Pointer, /* Next available slot in control stack */
- *Stack_Top, /* Top of control stack */
- *Stack_Guard, /* Guard area at end of stack */
- *Free_Stacklets, /* Free list of stacklets */
- *Constant_Space, /* Bottom of constant+pure space */
- *Free_Constant, /* Next free cell in constant+pure area */
- *Heap_Top, /* Top of current heap space */
- *Heap_Bottom, /* Bottom of current heap space */
- *Unused_Heap_Top, /* Top of unused heap for GC */
- *Unused_Heap, /* Bottom of unused heap for GC */
- *Local_Heap_Base, /* Per-processor CONSing area */
- *Heap, /* Bottom of all heap space */
- Current_State_Point, /* Dynamic state point */
- Fluid_Bindings, /* Fluid bindings AList */
- return_to_interpreter, /* Return address/code left by interpreter
- when calling compiled code */
- *last_return_code; /* Address of the most recent return code in the stack.
- This is only meaningful while in compiled code.
- *** This must be changed when stacklets are used. ***
- */
-
-extern Declare_Fixed_Objects();
-\f
-extern long IntCode, /* Interrupts requesting */
- IntEnb, /* Interrupts enabled */
- GC_Reserve, /* Scheme pointer overflow space in heap */
- GC_Space_Needed, /* Amount of space needed when GC triggered */
- /* Used to signal microcode errors from compiled code. */
- compiled_code_error_code;
-
-/* The lookup routines receive the slot location using these: */
-extern Pointer Lookup_Base;
-extern long Lookup_Offset;
-
-extern char *Return_Names[];
-extern long MAX_RETURN;
-
-extern char *CONT_PRINT_RETURN_MESSAGE,
- *CONT_PRINT_EXPR_MESSAGE,
- *RESTORE_CONT_RETURN_MESSAGE,
- *RESTORE_CONT_EXPR_MESSAGE;
-
-extern int GC_Type_Map[];
-
-extern Boolean Photo_Open; /* Photo file open */
-extern jmp_buf *Back_To_Eval;
-extern Boolean Trapping;
-extern Pointer Old_Return_Code, *Return_Hook_Address;
-
-extern Pointer *Prev_Restore_History_Stacklet;
-extern long Prev_Restore_History_Offset;
-\f
-/* And file "channels" */
-
-extern FILE *(Channels[FILE_CHANNELS]);
-extern FILE *File_Handle; /* Used by Fasload/Fasdump */
-extern FILE *Photo_File_Handle; /* Used by Photo */
-
-extern int Saved_argc;
-extern char **Saved_argv;
-extern char *OS_Name, *OS_Variant;
-extern long Heap_Size, Constant_Size, Stack_Size;
-extern Pointer *Highest_Allocated_Address;
-\f
-/* Environment lookup utilities. */
-
-extern long Lex_Ref(), Local_Set(), Lex_Set(),
- Symbol_Lex_Ref(), Symbol_Lex_Set();
-
-/* String utilities */
-
-extern Pointer C_String_To_Scheme_String();
-
-#define Scheme_String_To_C_String(Scheme_String) \
- ((char *) Nth_Vector_Loc(Scheme_String, STRING_CHARS))
-
-/* Numeric utilities */
-
-extern int Scheme_Integer_To_C_Integer();
-extern Pointer C_Integer_To_Scheme_Integer(), Allocate_Float(),
- Float_To_Big(), Big_To_Float(), Big_To_Fix(),
- Fix_To_Big();
-
-/* Random and OS utilities */
-
-extern int Parse_Option();
-extern Boolean Open_File(), Restore_History(), Open_Dump_File();
-extern long NColumns(), NLines(), System_Clock();
-extern void OS_Flush_Output_Buffer();
-extern void Load_Data(), Write_Data(), OS_Re_Init();
-
-/* Memory management utilities */
-
-extern Pointer Purify_Pass_2(), Fasload();
-extern Boolean Pure_Test();
-
-/* Interpreter utilities */
-
-extern term_type Microcode_Termination();
-extern void Interpret(), Do_Micro_Error(), Setup_Interrupt(),
- Back_Out_Of_Primitive(), Translate_To_Point(),
- Stop_History(), Stack_Death();
-
-#ifdef USE_STACKLETS
-extern void Allocate_New_Stacklet();
-#endif
-
-extern Pointer *Make_Dummy_History(), Find_State_Space();
-
-/* Debugging utilities */
-
-extern void Back_Trace(), Handle_Debug_Flags(),
- Find_Symbol(), Show_Env(), Show_Pure(),
- Print_Return(), Print_Expression(), Print_Primitive();
-\f
-/* Conditional utilities */
-
-#if false
-extern void Clear_Perfinfo_Data();
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.25 1987/04/16 14:34:02 jinx Exp $
-
- This file contains code for fasdump and dump-band.
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-#define In_Fasdump
-#include "gccode.h"
-#include "trap.h"
-#include "lookup.h"
-#include "dump.c"
-
-extern Pointer Make_Prim_Exts();
-\f
-/* Some statics used freely in this file */
-Pointer *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
-
-/* FASDUMP:
-
- Hair squared! ... in order to dump an object it must be traced (as
- in a garbage collection), but with some significant differences.
- First, the copy must have the global value cell of symbols set to
- UNBOUND and variables uncompiled. Second, and worse, all the
- broken hearts created during the process must be restored to their
- original values. This last is done by growing the copy of the
- object in the bottom of spare heap, keeping track of the locations
- of broken hearts and original contents at the top of the spare
- heap.
-
- FASDUMP is called with three arguments:
- Argument 1: Base of spare heap
- Argument 2: Top of spare heap
- Argument 3: Hunk 3, #<Object to dump | File name | Flag>
- where the flag is #!true for a dump into constant
- space at reload time, () for a dump into heap.
-
- As with Purify, dumping an object for reloading into constant space
- requires dividing it into pure and constant parts and building a
- standard Pure/Constant block.
-*/
-\f
-/*
- Copy of GCLoop, except (a) copies out of constant space into the
- object to be dumped; (b) changes symbols and variables as
- described; (c) keeps track of broken hearts and their original
- contents (e) To_Pointer is now NewFree.
-*/
-
-#define Dump_Pointer(Code) \
-Old = Get_Pointer(Temp); \
-Code
-
-#define Setup_Pointer_for_Dump(Extra_Code) \
-Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
-
-/* Dump_Mode is currently a fossil. It should be resurrected. */
-
-/* Should be big enough for the largest fixed size object (a Quad)
- and 2 for the Fixup.
- */
-
-#define FASDUMP_FIX_BUFFER 10
-
-Boolean DumpLoop(Scan, Dump_Mode)
-fast Pointer *Scan;
-int Dump_Mode;
-{ fast Pointer *To, *Old, Temp, New_Address, *Fixes;
-
- To = NewFree;
- Fixes = Fixup;
-
- for ( ; Scan != To; Scan++)
- { Temp = *Scan;
-
- Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
- if (Datum(Temp) != 0)
- { fprintf(stderr, "\nDump: Broken heart in scan.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += Get_Integer(Temp);
- break;
-
- /* This should really be case_Fasdump_Non_Pointer,
- and PRIMITIVE_EXTERNAL should be handled specially
- */
- case_Non_Pointer:
- break;
-
- case_compiled_entry_point:
- Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(),
- Compiled_BH(false, continue)));
-
- case_Cell:
- Setup_Pointer_for_Dump(Transport_Cell());
-
- case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
- break;
- }
- /* Fall through. */
- case TC_WEAK_CONS:
- case_Fasdump_Pair:
- Setup_Pointer_for_Dump(Transport_Pair());
-
- case TC_INTERNED_SYMBOL:
- Setup_Pointer_for_Dump(Fasdump_Symbol(Make_Broken_Heart(0)));
-
- case TC_UNINTERNED_SYMBOL:
- Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT));
-
- case_Triple:
- Setup_Pointer_for_Dump(Transport_Triple());
-
- case TC_VARIABLE:
- Setup_Pointer_for_Dump(Fasdump_Variable());
-
-/* DumpLoop continues on the next page */
-\f
-/* DumpLoop, continued */
-
- case_Quadruple:
- Setup_Pointer_for_Dump(Transport_Quadruple());
-
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- Setup_Pointer_for_Dump(Transport_Flonum());
-#else
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
- case_Vector:
- Setup_Pointer_for_Dump(Transport_Vector());
-
- case TC_FUTURE:
- Setup_Pointer_for_Dump(Transport_Future());
-
- default:
- fprintf(stderr,
- "DumpLoop: Bad type code = 0x%02x\n",
- Type_Code(Temp));
- Invalid_Type_Code();
-
- } /* Switch_by_GC_Type */
- } /* For loop */
- NewFree = To;
- Fixup = Fixes;
- return true;
-} /* DumpLoop */
-\f
-void
-Fasdump_Exit()
-{
- fast Pointer *Fixes;
-
- Fixes = Fixup;
- fclose(File_Handle);
- while (Fixes != NewMemTop)
- {
- fast Pointer *Fix_Address;
-
- Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */
- *Fix_Address = *Fixes++; /* Put it there. */
- }
- Fixup = Fixes;
- Fasdump_Exit_Hook();
-}
-\f
-/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
- Dump an object into a file so that it can be loaded using
- BINARY-FASLOAD. A spare heap is required for this operation.
- The first argument is the object to be dumped. The second is
- the filename and the third a flag. The flag, if #!TRUE, means
- that the object is to be dumped for reloading into constant
- space. This is currently disabled. If the flag is NIL, it means
- that it will be reloaded into the heap. The primitive returns
- #!TRUE or NIL indicating whether it successfully dumped the
- object (it can fail on an object that is too large).
-
- The code for dumping pure is severely broken and conditionalized out.
-*/
-Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
-{
- Pointer Object, File_Name, Flag, *New_Object,
- *Addr_Of_New_Object, Prim_Exts;
- long Pure_Length, Length;
- Primitive_3_Args();
-
- Object = Arg1;
- File_Name = Arg2;
- Flag = Arg3;
- if (Type_Code(File_Name) != TC_CHARACTER_STRING)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (!Open_Dump_File(File_Name, WRITE_FLAG))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
-#if false
- if ((Flag != NIL) && (Flag != TRUTH))
-#else
- if (Flag != NIL)
-#endif
- Primitive_Error(ERR_ARG_3_WRONG_TYPE);
-
- Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
- Fixup = NewMemTop;
- Prim_Exts = Make_Prim_Exts();
- New_Object = NewFree;
- *NewFree++ = Object;
- *NewFree++ = Prim_Exts;
-\f
-#if false
- if (Flag == TRUTH)
- { if (!DumpLoop(New_Object, PURE_COPY))
- {
- Fasdump_Exit();
- return NIL;
- }
- /* Can't align.
- Align_Float(NewFree);
- */
- Pure_Length = (NewFree-New_Object) + 1;
- *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
- if (!DumpLoop(New_Object, CONSTANT_COPY))
- {
- Fasdump_Exit();
- return NIL;
- }
- Length = NewFree-New_Object+2;
- *NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, Length-1);
- Addr_Of_New_Object = Get_Pointer(New_Object[0]);
- Prim_Exts = New_Object[1];
- New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
- Pure_Length);
- New_Object[1] = Make_Non_Pointer(PURE_PART, Length-1);
- Write_File(0, 0x000000, Addr_Of_New_Object,
- Length, New_Object, Prim_Exts);
- }
- else /* Dumping for reload into heap */
-#endif
- { if (!DumpLoop(New_Object, NORMAL_GC))
- {
- Fasdump_Exit();
- return NIL;
- }
- /* Aligning might screw up some of the counters.
- Align_Float(NewFree);
- */
- Length = NewFree-New_Object;
- Write_File(Length, New_Object, New_Object,
- 0, Constant_Space, New_Object+1);
- }
- Fasdump_Exit();
- return TRUTH;
-}
-\f
-/* (DUMP-BAND PROCEDURE FILE-NAME)
- Saves all of the heap and pure space on FILE-NAME. When the
- file is loaded back using BAND_LOAD, PROCEDURE is called with an
- argument of NIL.
-*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
-{
- Pointer Combination, Ext_Prims;
- long Arg1Type;
- Primitive_2_Args();
-
- Band_Dump_Permitted();
- Arg1Type = Type_Code(Arg1);
- if ((Arg1Type != TC_CONTROL_POINT) &&
- (Arg1Type != TC_PRIMITIVE) &&
- (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
- (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
- Arg_2_Type(TC_CHARACTER_STRING);
- if (!Open_Dump_File(Arg2, WRITE_FLAG))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- /* Free cannot be saved around this code since Make_Prim_Exts will
- intern the undefined externals and potentially allocate space.
- */
- Ext_Prims = Make_Prim_Exts();
- Combination = Make_Pointer(TC_COMBINATION_1, Free);
- Free[COMB_1_FN] = Arg1;
- Free[COMB_1_ARG_1] = NIL;
- Free += 2;
- *Free++ = Combination;
- *Free++ = return_to_interpreter;
- *Free = Make_Pointer(TC_LIST, Free-2);
- Free++; /* Some compilers are TOO clever about this and increment Free
- before calculating Free-2! */
- *Free++ = Ext_Prims;
- /* Aligning here confuses some of the counts computed.
- Align_Float(Free);
- */
- Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2,
- ((long) (Free_Constant-Constant_Space)),
- Constant_Space, Free-1);
- fclose(File_Handle);
- return TRUTH;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
-
- Contains information relating to the format of FASL files.
- Some information is contained in CONFIG.H.
-*/
-\f
-/* FASL Version */
-
-#define FASL_FILE_MARKER 0XFAFAFAFA
-
-/* The FASL file has a header which begins as follows: */
-
-#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */
-#define FASL_OLD_LENGTH 8 /* Size of header earlier */
-#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */
-#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */
-#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */
-#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */
-#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */
-#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
-#define FASL_Offset_Version 6 /* FASL format version info. */
-#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
-#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
-
-#define FASL_Offset_First_Free 9 /* Used to clear header */
-
-/* Version information encoding */
-
-#define MACHINE_TYPE_LENGTH (POINTER_LENGTH/2)
-#define MACHINE_TYPE_MASK ((1<<MACHINE_TYPE_LENGTH)-1)
-#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
-#define SUB_VERSION_LENGTH (MACHINE_TYPE_LENGTH-TYPE_CODE_LENGTH)
-#define SUB_VERSION_MASK ((1<<SUB_VERSION_LENGTH)-1)
-#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK)
-#define The_Version(P) Type_Code(P)
-#define Make_Version(V, S, M) \
- Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-
-#define WRITE_FLAG "w"
-#define OPEN_FLAG "r"
-\f
-/* "Memorable" FASL versions -- ones where we modified something
- and want to remain backwards compatible.
-*/
-
-/* Versions. */
-
-#define FASL_FORMAT_ADDED_STACK 1
-
-/* Subversions of highest numbered version. */
-
-#define FASL_LONG_HEADER 3
-#define FASL_DENSE_TYPES 4
-#define FASL_PADDED_STRINGS 5
-#define FASL_REFERENCE_TRAP 6
-
-/* Current parameters. */
-
-#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_REFERENCE_TRAP
-#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.25 1987/04/16 02:21:50 jinx Exp $
-
- The "fast loader" which reads in and relocates binary files and then
- interns symbols. It is called with one argument: the (character
- string) name of a file to load. It is called as a primitive, and
- returns a single object read in.
- */
-\f
-#include "scheme.h"
-#include "primitive.h"
-#include "gccode.h"
-#include "trap.h"
-
-#define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug)
-#define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug)
-
-#include "load.c"
-\f
-void
-Load_File(Name)
- Pointer Name;
-{
- char *Char;
- long N, i;
- Boolean File_Opened;
-
- File_Opened = Open_Dump_File(Name, OPEN_FLAG);
- if (Per_File)
- Handle_Debug_Flags();
- if (!File_Opened)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- if (!Read_Header())
- { fprintf(stderr,
- "\nLoad_File: The file does not appear to be in FASL format.\n");
- goto CANNOT_LOAD;
- }
- if (File_Load_Debug)
- printf("\nMachine type %d, Version %d, Subversion %d\n",
- Machine_Type, Version, Sub_Version);
-\f
-#ifdef BYTE_INVERSION
- if ((Sub_Version != FASL_SUBVERSION))
-#else
- if ((Sub_Version != FASL_SUBVERSION) ||
- (Machine_Type != FASL_INTERNAL_FORMAT))
-#endif
-
- {
- fprintf(stderr,
- "\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- " Expected: Version %4d Subversion %4d Machine Type %4d.\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
-CANNOT_LOAD:
- fclose(File_Handle);
- Primitive_Error(ERR_FASL_FILE_BAD_DATA);
- }
- if (!Test_Pure_Space_Top(Free_Constant+Const_Count))
- {
- fclose(File_Handle);
- Primitive_Error(ERR_FASL_FILE_TOO_BIG);
- }
- if (GC_Check(Heap_Count))
- {
- fclose(File_Handle);
- Request_GC(Heap_Count);
- Primitive_Interrupt();
- }
- /* Aligning Free here confuses the counters
- Align_Float(Free);
- */
- Load_Data(Heap_Count, (char *) Free);
-#ifdef BYTE_INVERSION
- Byte_Invert_Region((char *) Free, Heap_Count);
-#endif
- Free += Heap_Count;
- Load_Data(Const_Count, (char *) Free_Constant);
-#ifdef BYTE_INVERSION
- Byte_Invert_Region((char *) Free_Constant, Const_Count);
-#endif
- Free_Constant += Const_Count;
- /* Same
- Align_Float(Free);
- */
- fclose(File_Handle);
- return;
-}
-\f
-/* Statics used by Relocate, below */
-
-relocation_type Heap_Relocation, Const_Reloc, Stack_Relocation;
-
-/* Relocate a pointer as read in from the file. If the pointer used
- to point into the heap, relocate it into the heap. If it used to
- be constant area, relocate it to constant area. Otherwise give an
- error.
-*/
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-static Boolean Warned = false;
-Pointer *
-Relocate(P)
- long P;
-{
- Pointer *Result;
-
- if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
- Result = (Pointer *) (P + Heap_Relocation);
- else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
- Result = (Pointer *) (P + Const_Reloc);
- else if (P < Dumped_Stack_Top)
- Result = (Pointer *) (P + Stack_Relocation);
- else
- {
- printf("Pointer out of range: 0x%x\n", P, P);
- if (!Warned)
- {
- printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n",
- Heap_Base, Dumped_Heap_Top,
- Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
- Warned = true;
- }
- Result = (Pointer *) 0;
- }
- if (Reloc_Debug)
- printf("0x%06x -> 0x%06x\n", P, Result);
- return Result;
-}
-
-#define Relocate_Into(Loc, P) (Loc) = Relocate(P)
-
-#else
-
-#define Relocate_Into(Loc, P) \
-if ((P) < Const_Base) \
- (Loc) = ((Pointer *) ((P) + Heap_Relocation)); \
-else if ((P) < Dumped_Constant_Top) \
- (Loc) = ((Pointer *) ((P) + Const_Reloc)); \
-else \
- (Loc) = ((Pointer *) ((P) + Stack_Relocation))
-
-#ifndef Conditional_Bug
-#define Relocate(P) \
- ((P < Const_Base) ? \
- ((Pointer *) (P + Heap_Relocation)) : \
- ((P < Dumped_Constant_Top) ? \
- ((Pointer *) (P + Const_Reloc)) : \
- ((Pointer *) (P + Stack_Relocation))))
-#else
-static Pointer *Relocate_Temp;
-#define Relocate(P) \
- (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
-#endif
-#endif
-\f
-/* Next_Pointer starts by pointing to the beginning of the block of
- memory to be handled. This loop relocates all pointers in the
- block of memory.
-*/
-
-long
-Relocate_Block(Next_Pointer, Stop_At)
- fast Pointer *Next_Pointer, *Stop_At;
-{
- if (Reloc_Debug)
- fprintf(stderr,
- "Relocation beginning, block=0x%x, length=0x%x, end=0x%x.\n",
- Next_Pointer, (Stop_At-Next_Pointer)-1, Stop_At);
- while (Next_Pointer < Stop_At)
- {
- fast Pointer Temp;
-
- Temp = *Next_Pointer;
- Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_Fasdump_Non_Pointer:
- Next_Pointer += 1;
- break;
-
- case TC_PRIMITIVE_EXTERNAL:
- Found_Ext_Prims = true;
- Next_Pointer += 1;
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(Temp)+1;
- break;
-
-#ifdef BYTE_INVERSION
- case TC_CHARACTER_STRING:
- String_Inversion(Relocate(Datum(Temp)));
- /* THEN FALL THROUGH */
-#endif
-
- case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- Next_Pointer += 1;
- break;
- }
- /* It is a pointer, fall through. */
- case_compiled_entry_point:
- /* Compiled entry points work automagically. */
- default:
- {
- fast long Next;
-
- Next = Datum(Temp);
- *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
- }
- }
- }
-}
-\f
-extern void Intern();
-
-void
-Intern_Block(Next_Pointer, Stop_At)
- Pointer *Next_Pointer, *Stop_At;
-{
- if (Reloc_Debug)
- printf("Interning a block.\n");
-
- while (Next_Pointer <= Stop_At) /* BBN has < for <= */
- {
- switch (Type_Code(*Next_Pointer))
- { case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(*Next_Pointer)+1;
- break;
-
- case TC_INTERNED_SYMBOL:
- if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
- TC_BROKEN_HEART)
- {
- Pointer Old_Symbol;
-
- Old_Symbol = *Next_Pointer;
- Vector_Set(*Next_Pointer, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
- Intern(Next_Pointer);
- Primitive_GC_If_Needed(0);
- if (*Next_Pointer != Old_Symbol)
- {
- Vector_Set(Old_Symbol, SYMBOL_NAME,
- Make_New_Pointer(TC_BROKEN_HEART, *Next_Pointer));
- }
- }
- else if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) ==
- TC_BROKEN_HEART)
- {
- *Next_Pointer =
- Make_New_Pointer(Type_Code(*Next_Pointer),
- Fast_Vector_Ref(*Next_Pointer,
- SYMBOL_NAME));
- }
- Next_Pointer += 1;
- break;
-
- default: Next_Pointer += 1;
- }
- }
- if (Reloc_Debug)
- printf("Done interning block.\n");
- return;
-}
-\f
-/* Install the external primitives vector. This requires changing
- the Ext_Prim_Vector from a vector of symbols (which is what is
- in the FASL file) into a vector of (C format) numbers representing
- the corresponding external primitives numbers for this interpreter.
- If an external primitive is known, then the existing assigned number
- is used. If not, the symbol is added to the list of assigned
- numbers. In the case of a band load (as opposed to a fasload),
- the existing vector of known but unimplemented external primitives
- is ignored and a completely new one will be built.
-*/
-
-void
-Install_Ext_Prims(Normal_FASLoad)
- Boolean Normal_FASLoad;
-{
- long i;
- Pointer *Next;
-
- Vector_Set(Ext_Prim_Vector, 0,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Ext_Prim_Count));
- Next = Nth_Vector_Loc(Ext_Prim_Vector, 1);
- if (Normal_FASLoad)
- for (i = 0; i < Ext_Prim_Count; i++) Intern(Next++);
- else Undefined_Externals = NIL;
- return;
-}
-\f
-void
-Update_Ext_Prims(Next_Pointer, Stop_At)
- fast Pointer *Next_Pointer, *Stop_At;
-{
- extern long make_external_primitive();
-
- for ( ; Next_Pointer < Stop_At; Next_Pointer++)
- { switch (Type_Code(*Next_Pointer))
- { case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(*Next_Pointer);
- break;
-
- case TC_PRIMITIVE_EXTERNAL:
- {
- long Which;
-
- Which = Address(*Next_Pointer);
-
- if (Which > Ext_Prim_Count)
- fprintf(stderr, "\nExternal Primitive 0x%x out of range.\n", Which);
- else
- {
- Pointer New_Value;
-
- New_Value = User_Vector_Ref(Ext_Prim_Vector, Which);
- if (Type_Code(New_Value) == TC_INTERNED_SYMBOL)
- {
- New_Value = ((Pointer) make_external_primitive(New_Value, TRUTH));
- User_Vector_Set(Ext_Prim_Vector, Which, New_Value);
- }
- Store_Address(*Next_Pointer, New_Value);
- }
- }
-
- default: break;
- }
- }
- return;
-}
-\f
-Pointer
-Fasload(FileName, Not_From_Band_Load)
- Pointer FileName;
- Boolean Not_From_Band_Load;
-{
- Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
-
-#ifdef ENABLE_DEBUGGING_TOOLS
- Warned = false;
-#endif
-
- if (Type_Code(FileName) != TC_CHARACTER_STRING)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- /* Read File */
-
- Orig_Heap = Free;
- Orig_Constant = Free_Constant;
- Load_File(FileName);
- Heap_End = Free;
- Constant_End = Free_Constant;
- Heap_Relocation = ((relocation_type) Orig_Heap) - Heap_Base;
- Const_Reloc = ((relocation_type) Orig_Constant) - Const_Base;
- Stack_Relocation = ((relocation_type) Stack_Top) - Dumped_Stack_Top;
-
- if (Reloc_Debug)
- printf("Heap_relocation = %d = %x; Const_Reloc = %d = %x\n",
- Heap_Relocation, Heap_Relocation,
- Const_Reloc, Const_Reloc);
-
- /* Relocate the new Data */
-
-#ifdef BYTE_INVERSION
- Setup_For_String_Inversion();
-#endif
-
- Found_Ext_Prims = false;
- Relocate_Block(Orig_Heap, Free);
- Relocate_Block(Orig_Constant, Free_Constant);
-
-#ifdef BYTE_INVERSION
- Finish_String_Inversion();
-#endif
-\f
- if (Not_From_Band_Load)
- {
- Intern_Block(Orig_Constant, Constant_End);
- Intern_Block(Orig_Heap, Heap_End);
- }
-
- /* Update External Primitives */
-
- if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims)
- {
- Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
- Ext_Prim_Vector = *Xtemp;
- Ext_Prim_Count = Vector_Length(Ext_Prim_Vector);
- Install_Ext_Prims(Not_From_Band_Load);
- Update_Ext_Prims(Orig_Heap, Free);
- Update_Ext_Prims(Orig_Constant, Free_Constant);
- }
-
- Set_Pure_Top();
- Relocate_Into(Xtemp, Dumped_Object);
- return *Xtemp;
-}
-\f
-/* (BINARY-FASLOAD FILE-NAME)
- Load the contents of FILE-NAME into memory. The file was
- presumably made by a call to PRIMITIVE-FASDUMP, and may contain
- data for the heap and/or the pure area. The value returned is
- the object which was dumped. Typically (but not always) this
- will be a piece of SCode which is then evaluated to perform
- definitions in some environment.
-*/
-Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57)
-{
- Primitive_1_Arg();
- return Fasload(Arg1, true);
-}
-\f
-/* Band loading. */
-
-static char *reload_band_name = ((char *) NULL);
-
-/* (RELOAD-BAND-NAME)
- Returns the filename (as a Scheme string) from which the runtime system
- was band loaded (load-band'ed ?), or NIL if the system was fasl'ed.
-*/
-Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME", 0x1A3)
-{
- Primitive_0_Args();
-
- if (reload_band_name == NULL)
- return NIL;
-
- return C_String_To_Scheme_String(reload_band_name);
-}
-
-/* (LOAD-BAND FILE-NAME)
- Restores the heap and pure space from the contents of FILE-NAME,
- which is typically a file created by DUMP-BAND. The file can,
- however, be any file which can be loaded with BINARY-FASLOAD.
-*/
-Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9)
-{
- Pointer Save_FO, *Save_Free, *Save_Free_Constant,
- Save_Undefined, *Save_Stack_Pointer,
- *Save_Stack_Guard, Result;
-
- long Jump_Value;
- jmp_buf Swapped_Buf, *Saved_Buf;
- Pointer scheme_band_name;
- char *band_name;
- int length;
- Primitive_1_Arg();
-
- band_name = ((char *) NULL);
- Save_Fixed_Obj(Save_FO);
- Save_Undefined = Undefined_Externals;
- Undefined_Externals = NIL;
- Save_Free = Free;
- Free = Heap_Bottom;
- Save_Free_Constant = Free_Constant;
- Free_Constant = Constant_Space;
- Save_Stack_Pointer = Stack_Pointer;
- Save_Stack_Guard = Stack_Guard;
-
-/* Prim_Band_Load continues on next page */
-\f
-/* Prim_Band_Load, continued */
-
- /* There is some jiggery-pokery going on here to make sure
- that all returns from Fasload (including error exits) return to
- the clean-up code before returning on up the C call stack.
- */
- Saved_Buf = Back_To_Eval;
- Jump_Value = setjmp(Swapped_Buf);
- if (Jump_Value == 0)
- { extern char *malloc();
- extern strcpy(), free();
-
- length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
- band_name = malloc(length);
- if (band_name != ((char *) NULL))
- strcpy(band_name, Scheme_String_To_C_String(Arg1));
-
- Back_To_Eval = (jmp_buf *) Swapped_Buf;
- Result = Fasload(Arg1, false);
- Back_To_Eval = Saved_Buf;
-
- if (reload_band_name != ((char *) NULL))
- free(reload_band_name);
- reload_band_name = band_name;
- History = Make_Dummy_History();
- Initialize_Stack();
- Store_Return(RC_END_OF_COMPUTATION);
- Store_Expression(NIL);
- Save_Cont();
- Store_Expression(Vector_Ref(Result,0));
- /* Primitive externals handled by Fasload */
- return_to_interpreter = Vector_Ref(Result, 1);
- Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
- Set_Pure_Top();
- Band_Load_Hook();
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
- }
- else
- { if (band_name != ((char *) NULL))
- free(band_name);
- Back_To_Eval = Saved_Buf;
- Free = Save_Free;
- Free_Constant = Save_Free_Constant;
- Stack_Pointer = Save_Stack_Pointer;
- Set_Stack_Guard(Save_Stack_Guard);
- Undefined_Externals = Save_Undefined;
- Restore_Fixed_Obj(Save_FO);
- if (Jump_Value == PRIM_INTERRUPT)
- { printf("\nFile too large for memory.\n");
- Jump_Value = ERR_FASL_FILE_BAD_DATA;
- }
- Primitive_Error(Jump_Value);
- }
-}
-\f
-#ifdef BYTE_INVERSION
-
-#define MAGIC_OFFSET (TC_FIXNUM + 1)
-
-Pointer String_Chain, Last_String;
-extern Boolean Byte_Invert_Fasl_Files;
-
-Setup_For_String_Inversion()
-{
- if (!Byte_Invert_Fasl_Files)
- return;
- String_Chain = NIL;
- Last_String = NIL;
-}
-
-Finish_String_Inversion()
-{ while (String_Chain != NIL)
- { long Count;
- Pointer Next;
-
- if (!Byte_Invert_Fasl_Files) return;
-
- Count = Get_Integer(Fast_Vector_Ref(String_Chain, STRING_HEADER));
- Count = 4*(Count-2)+Type_Code(String_Chain)-MAGIC_OFFSET;
- if (Reloc_Debug)
- printf("String at 0x%x: restoring length of %d.\n",
- Address(String_Chain), Count);
- Next = Fast_Vector_Ref(String_Chain, STRING_LENGTH);
- Fast_Vector_Set(String_Chain, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
- String_Chain = Next;
- }
-}
-\f
-#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
- "\\%03o" : "%c", (C && MAX_CHAR));
-
-String_Inversion(Orig_Pointer)
-Pointer *Orig_Pointer;
-{ Pointer *Pointer_Address;
- char *To_Char;
- long Code;
-
- if (!Byte_Invert_Fasl_Files) return;
-
- Code = Type_Code(Orig_Pointer[STRING_LENGTH]);
- if (Code == TC_FIXNUM || Code == 0) /* Already reversed? */
- { long Count, old_size, new_size, i;
-
- old_size = Get_Integer(Orig_Pointer[STRING_HEADER]);
- new_size =
- 2+(Get_Integer(Orig_Pointer[STRING_LENGTH]))/4;
-
- if (Reloc_Debug)
- printf("\nString at 0x%x with %d characters",
- Orig_Pointer,
- Get_Integer(Orig_Pointer[STRING_LENGTH]));
-
- if (old_size != new_size)
- { printf("\nWord count changed from %d to %d: ",
- old_size , new_size);
- printf("\nWhich, of course, is impossible!!\n");
- Microcode_Termination(TERM_EXIT);
- }
-
- Count = Get_Integer(Orig_Pointer[STRING_LENGTH])%4;
- if (Count==0) Count = 4;
- if (Last_String == NIL)
- String_Chain = Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer);
- else Fast_Vector_Set(Last_String, STRING_LENGTH,
- Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer));
- Last_String = Make_Pointer(TC_NULL, Orig_Pointer);
- Orig_Pointer[STRING_LENGTH] = NIL;
- Count = Get_Integer(Orig_Pointer[STRING_HEADER])-1;
- if (Reloc_Debug)
- printf("\nCell count=%d\n", Count);
- Pointer_Address = &(Orig_Pointer[STRING_CHARS]);
- To_Char = (char *) Pointer_Address;
- for (i=0; i < Count; i++, Pointer_Address++)
- { int C1, C2, C3, C4;
- C4 = Type_Code(*Pointer_Address) & 0xFF;
- C3 = (((long) *Pointer_Address)>>16) & 0xFF;
- C2 = (((long) *Pointer_Address)>>8) & 0xFF;
- C1 = ((long) *Pointer_Address) & 0xFF;
- if (Reloc_Debug || (old_size != new_size))
- { print_char(C1);
- print_char(C2);
- print_char(C3);
- print_char(C4);
- }
- *To_Char++ = C1;
- *To_Char++ = C2;
- *To_Char++ = C3;
- *To_Char++ = C4;
- }
- }
- if (Reloc_Debug) printf("\n");
-}
-#endif /* BYTE_INVERSION */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fft.c,v 9.21 1987/01/22 14:24:33 jinx Rel $ */
-
-/* FFT scheme primitive, using YEKTA FFT */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "flonum.h"
-#include "zones.h"
-#include <math.h>
-#include "array.h"
-#include "image.h"
-\f
-#define mult(pf1, pf2, pg1, pg2, w1, w2) \
- { int x, y, p2, p3, p4, p5, p6, p7; \
- REAL tmp1, tmp2; \
- a = a / 2; \
- p2 = - a; \
- p3 = 0; \
- for ( x = 1; x <= n2; x = x + a ) { \
- p2 = p2 + a; \
- for( y = 1; y <= a; ++y ) { \
- ++p3; \
- p4 = p2 + 1; \
- p5 = p2 + p3; \
- p5 = ((p5-1) % n) + 1; \
- p6 = p5 + a; \
- tmp1 = w1[p4-1] * pf1[p6-1] \
- - w2[p4-1] * pf2[p6-1]; \
- tmp2 = w1[p4-1] * pf2[p6-1] \
- + w2[p4-1] * pf1[p6-1]; \
- pg1[p3-1] = pf1[p5-1] + tmp1; \
- pg2[p3-1] = pf2[p5-1] + tmp2; \
- p7 = p3 + n2; \
- pg1[p7-1] = pf1[p5-1] - tmp1; \
- pg2[p7-1] = pf2[p5-1] - tmp2; \
- } \
- } \
-}
-\f
-/* n is length, nu is power, w1,w2 are locations for twiddle tables, */
-/* f1,f2,g1,g2 are locations for fft, and flag is for forward(1) or inverse(-1) */
-/* w1,w2 are half the size of f1,f2,g1,g2 */
-
-/* f1,f2 contain the real and imaginary parts of the signal */
-/* The answer is left in f1, f2 */
-\f
-C_Array_FFT(flag, nu, n, f1, f2, g1,g2,w1,w2) long flag, nu, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
-{ long n2=n>>1, a;
- long i, l, m;
- REAL twopi = 6.28318530717958, tm, k;
-
- a = n; /* initially equal to length */
- if (flag == 1) k=1.0;
- else k = -1.0;
- /* if ( nu > 12 ) Primitive_Error(ERR_ARG_2_BAD_RANGE); */ /* maximum power FFT */
-
- for (m=0; m<n; m++) {
- g1[m] = f1[m];
- g2[m] = f2[m];
- }
-
- for (m=0; m<n2; m++) {
- tm = twopi * ((REAL) m) / ((REAL) n);
- w1[m] = cos( tm );
- w2[m] = k * sin( tm ); /* k is the flag */
- }
-
- if ((nu % 2) == 1) l = 2;
- else l = 1;
- for ( i = l; i <= nu ; i = i + 2 ) {
- mult(g1,g2,f1,f2,w1,w2);
- mult(f1,f2,g1,g2,w1,w2);
- }
-
- if (k==1.0) { /* forward fft */
- if (l==1) { /* even power */
- for (m=0; m<n; m++) {
- f1[m] = g1[m]; f2[m] = g2[m];
- }
- }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- }}
- else { /* backward fft */
- tm = 1. / ((REAL) n); /* normalizing factor */
- if (l==1) { /* even power */
- for (m=0; m<n; m++) {
- f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
- }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- for (m=0; m<n; m++) {
- f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }
- }
- }
-}
-\f
-Make_Twiddle_Tables(w1, w2, n, k) REAL *w1, *w2; long n, k; /* n is the length of FFT */
-{ long m, n2=n/2;
- REAL tm, twopi = 6.28318530717958;
- for (m=0; m<n2; m++) {
- tm = twopi * ((REAL) m) / ((REAL) n);
- w1[m] = cos( tm );
- w2[m] = k * sin( tm ); /* k is -/+1 for forward/inverse fft */
- }
-}
-\f
-C_Array_FFT_With_Given_Tables(flag, nu, n, f1, f2, g1,g2,w1,w2)
- long flag, nu, n; REAL f1[], f2[], g1[], g2[], w1[], w2[];
-{ long n2=n>>1, a;
- long i, l, m;
- REAL twopi = 6.28318530717958, tm, k;
-
- a = n; /* initially equal to length */
- if (flag == 1) k=1.0;
- else k = -1.0;
-
- for (m=0; m<n; m++) {
- g1[m] = f1[m];
- g2[m] = f2[m];
- }
-
- if ((nu % 2) == 1) l = 2;
- else l = 1;
- for ( i = l; i <= nu ; i = i + 2 ) {
- mult(g1,g2,f1,f2,w1,w2);
- mult(f1,f2,g1,g2,w1,w2);
- }
-
-
-
- if (k==1.0) { /* forward fft */
- if (l==1) { /* even power */
- for (m=0; m<n; m++) {
- f1[m] = g1[m]; f2[m] = g2[m];
- }
- }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- }}
- else { /* backward fft */
- tm = 1. / ((REAL) n); /* normalizing factor */
- if (l==1) { /* even power */
- for (m=0; m<n; m++) {
- f1[m] = tm * g1[m]; f2[m] = tm * g2[m]; }
- }
- else { /* odd power ==> do one more mult */
- mult(g1,g2,f1,f2,w1,w2); /* f1 and f2 contain the result now */
- for (m=0; m<n; m++) {
- f1[m] = tm * f1[m]; f2[m] = tm * f2[m]; }
- }
- }
-}
-\f
-C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array)
- long flag, nrows, ncols; REAL *Real_Array, *Imag_Array;
-{ long i, j;
- REAL *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long nrows_power, ncols_power, Length = nrows*ncols;
-
- if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
- Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array);
- }
- else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
- /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
-
- for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- i=i/2; }
- for (nrows_power=0, i=nrows; i>1; nrows_power++) {
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- i=i/2; }
-
- Primitive_GC_If_Needed(Length*REAL_SIZE + ((max(nrows,ncols))*3*REAL_SIZE));
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- Make_Twiddle_Tables(w1,w2,ncols, flag);
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
-
- Temp_Array = Work_Here;
- Work_Here = Temp_Array + Length;
- Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
- Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
-
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- Make_Twiddle_Tables(w1,w2,nrows,flag);
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Temp_Array + (i*nrows); /* THIS IS REAL DATA */
- f2 = Real_Array + (i*nrows); /* THIS IS IMAG DATA */
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
-
- Image_Transpose(Real_Array, Imag_Array, ncols, nrows); /* DO FIRST THIS !!!, do not screw up Real_Data !!! */
- Image_Transpose(Temp_Array, Real_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
- }
-}
-\f
-Square_Image_2D_FFT_In_Scheme_Heap(flag, nrows, Real_Array, Imag_Array)
- long flag,nrows; REAL *Real_Array, *Imag_Array;
-{ REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long nrows_power;
- long i;
-
- for (nrows_power=0, i=nrows; i>1; nrows_power++) { /* FIND/CHECK POWERS OF ROWS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- i=i/2; }
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- Make_Twiddle_Tables(w1, w2, nrows, flag); /* MAKE TABLES */
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
- Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(Imag_Array, nrows);
-
- for (i=0;i<nrows;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2); /* ncols=nrows... Twiddles... */
- }
- Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(Imag_Array, nrows);
-}
-\f
-C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array)
- long flag, ndeps, nrows, ncols; REAL *Real_Array, *Imag_Array;
-{ long l, m, n;
- REAL *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
- long ndeps_power, nrows_power, ncols_power;
-
- if ((ndeps==nrows) && (nrows==ncols)) { /* CUBIC IMAGE, OPTIMIZE... */
- Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array);
- }
- else {
- for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWERS OF DEPS,ROWS,COLS */
- if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- l=l/2; }
- for (nrows_power=0, m=nrows; m>1; nrows_power++) {
- if ( (m % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- m=m/2; }
- for (ncols_power=0, n=ncols; n>1; ncols_power++) {
- if ( (n % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- n=n/2; }
-
- printf("3D FFT implemented only for cubic-spaces.\n");
- printf("aborted\n.");
- }
-}
-\f
-Cube_Space_3D_FFT_In_Scheme_Heap(flag, ndeps, Real_Array, Imag_Array)
- long flag, ndeps; REAL *Real_Array, *Imag_Array;
-{ register long l, m, n;
- register long ndeps_power, Surface_Length;
- register REAL *From_Real, *From_Imag;
- register REAL *f1,*f2,*g1,*g2,*w1,*w2, *Work_Here;
-
- for (ndeps_power=0, l=ndeps; l>1; ndeps_power++) { /* FIND/CHECK POWER OF NDEPS */
- if ( (l % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- l=l/2; }
- Primitive_GC_If_Needed(ndeps*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ndeps;
- w1 = Work_Here + (ndeps<<1);
- w2 = Work_Here + (ndeps<<1) + (ndeps>>1);
- Make_Twiddle_Tables(w1, w2, ndeps, flag); /* MAKE TABLES */
-
- Surface_Length=ndeps*ndeps;
- From_Real = Real_Array; From_Imag = Imag_Array;
-
- for (l=0; l<ndeps; l++,From_Real+=Surface_Length,From_Imag+=Surface_Length) { /* DEPTH-WISE */
-
- f1 = From_Real; f2 = From_Imag;
- for (m=0; m<ndeps; m++,f1+=ndeps,f2+=ndeps) { /* ROW-WISE */
- C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
- Image_Fast_Transpose(From_Real, ndeps); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(From_Imag, ndeps);
-
- /* ndeps=nrows=ncols, same Twiddle Tables */
-
- f1 = From_Real; f2 = From_Imag;
- for (n=0; n<ndeps; n++,f1+=ndeps,f2+=ndeps) { /* COLUMN-WISE */
- C_Array_FFT_With_Given_Tables(flag, ndeps_power, ndeps, f1,f2,g1,g2,w1,w2); }
- Image_Fast_Transpose(From_Real, ndeps); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(From_Imag, ndeps);
- }
-}
-
-\f
-/********************** below scheme primitives **********************/
-
-/* NOTE: IF Arg2 and Arg3 are EQ?, then it signals an error! */
-/* (Arg1 = 1 ==> forward FFT), otherwise inverse FFT */
-
-Define_Primitive(Prim_Array_FFT, 3, "ARRAY-FFT!")
-{ long length, length1, power, flag, i;
- Pointer answer;
- REAL *f1,*f2,*g1,*g2,*w1,*w2;
- REAL *Work_Here;
-
- Primitive_3_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Arg_2_Type(TC_ARRAY); /* real */
- Arg_3_Type(TC_ARRAY); /* imag */
- Set_Time_Zone(Zone_Math);
-
- flag = Get_Integer(Arg1);
- length = Array_Length(Arg2);
- length1 = Array_Length(Arg3);
-
- if (length != length1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- power=0;
- for (power=0, i=length; i>1; power++) {
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- i=i/2;
- }
-
- f1 = Scheme_Array_To_C_Array(Arg2);
- f2 = Scheme_Array_To_C_Array(Arg3);
- if (f1==f2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
-
- Primitive_GC_If_Needed(length*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + length;
- w1 = Work_Here + (length<<1);
- w2 = Work_Here + (length<<1) + (length>>1);
-
- C_Array_FFT(flag, power, length, f1,f2,g1,g2,w1,w2);
-
- Primitive_GC_If_Needed(4);
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg2;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg3;
- *Free++ = NIL;
- return answer;
-}
-\f
-Define_Primitive(Prim_Array_2D_FFT, 5, "ARRAY-2D-FFT!")
-{ long flag, i, j;
- Pointer answer;
- REAL *Real_Array, *Imag_Array, *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2;
- REAL *Work_Here;
- long Length, nrows, ncols, nrows_power, ncols_power;
-
- Primitive_5_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_4_Type(TC_ARRAY); /* real image */
- Arg_5_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- Sign_Extend(Arg1, flag); /* should be 1 or -1 */
- Length = Array_Length(Arg4);
- if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg4);
- Imag_Array = Scheme_Array_To_C_Array(Arg5);
- if (f1==f2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
-
- for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- i=i/2; }
- for (nrows_power=0, i=nrows; i>1; nrows_power++) {
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- i=i/2; }
-\f
- if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
- Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(Imag_Array, nrows);
-
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
- Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(Imag_Array, nrows);
- }
-\f
- else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
- /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
-
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Primitive_GC_If_Needed(ncols*3*REAL_SIZE);
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
-
- Temp_Array = Work_Here;
- Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
- Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Imag_Array, Length);
- Temp_Array = Real_Array; /* JUST POINTER SWITCHING */
- Real_Array = Imag_Array;
- Imag_Array = Temp_Array;
-
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
-
- Image_Transpose(Real_Array, Temp_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Transpose(Imag_Array, Real_Array, ncols, nrows); /* NOTE: switch in ncols nrows. */
- C_Array_Copy(Temp_Array, Imag_Array, Length); /* THIS UNDOES THE SWITCHING IN ARG4,ARG5 */
- }
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg4;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg5;
- *Free++ = NIL;
- return answer;
-}
-\f
-Define_Primitive(Prim_Array_2D_FFT_3, 5, "ARRAY-2D-FFT-3!")
-{ long flag, i, j;
- Pointer answer;
- REAL *Real_Array, *Imag_Array, *Temp_Array;
- REAL *f1,*f2,*g1,*g2,*w1,*w2;
- REAL *Work_Here;
- long Length, nrows, ncols, nrows_power, ncols_power;
-
- Primitive_5_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_4_Type(TC_ARRAY); /* real image */
- Arg_5_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- Sign_Extend(Arg1, flag); /* should be 1 or -1 */
- Length = Array_Length(Arg4);
- if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg4);
- Imag_Array = Scheme_Array_To_C_Array(Arg5);
- if (f1==f2) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
-
- for (ncols_power=0, i=ncols; i>1; ncols_power++) { /* FIND/CHECK POWERS OF ROWS,COLS */
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- i=i/2; }
- for (nrows_power=0, i=nrows; i>1; nrows_power++) {
- if ( (i % 2) == 1) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- i=i/2; }
-\f
- if (nrows==ncols) { /* SQUARE IMAGE, OPTIMIZE... */
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- Make_Twiddle_Tables(w1, w2, ncols, flag); /* MAKE TABLES */
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
- Image_Fast_Transpose(Real_Array, nrows); /* MUST TRANSPOSE (1) order of frequencies. (2) read columns. */
- Image_Fast_Transpose(Imag_Array, nrows);
-
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2); /* ncols=nrows... Twiddles... */
- }
- Image_Fast_Transpose(Real_Array, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Fast_Transpose(Imag_Array, nrows);
- }
-\f
- else { /* NOT A SQUARE IMAGE, CANNOT DO FAST_TRANSPOSE */
- /* FIRST (NCOLS-1)POINT FFTS FOR EACH ROW, THEN (NROWS-1)POINT FFTS FOR EACH COLUMN */
-
- Primitive_GC_If_Needed(nrows*3*REAL_SIZE);
- Primitive_GC_If_Needed(ncols*3*REAL_SIZE);
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Work_Here = (REAL *) Free;
- g1 = Work_Here;
- g2 = Work_Here + ncols;
- w1 = Work_Here + (ncols<<1);
- w2 = Work_Here + (ncols<<1) + (ncols>>1);
- Make_Twiddle_Tables(w1,w2,ncols, flag);
- for (i=0;i<nrows;i++) { /* ROW-WISE */
- f1 = Real_Array + (i*ncols);
- f2 = Imag_Array + (i*ncols);
- C_Array_FFT_With_Given_Tables(flag, ncols_power, ncols, f1,f2,g1,g2,w1,w2);
- }
-
- Temp_Array = Work_Here;
- Image_Transpose(Real_Array, Temp_Array, nrows, ncols); /* TRANSPOSE: (1) order of frequencies. (2) read columns.*/
- Image_Transpose(Imag_Array, Real_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Imag_Array, Length);
- Temp_Array = Real_Array; /* JUST POINTER SWITCHING */
- Real_Array = Imag_Array;
- Imag_Array = Temp_Array;
-
- g1 = Work_Here;
- g2 = Work_Here + nrows;
- w1 = Work_Here + (nrows<<1);
- w2 = Work_Here + (nrows<<1) + (nrows>>1);
- Make_Twiddle_Tables(w1,w2,nrows,flag);
- for (i=0;i<ncols;i++) { /* COLUMN-WISE */
- f1 = Real_Array + (i*nrows);
- f2 = Imag_Array + (i*nrows);
- C_Array_FFT_With_Given_Tables(flag, nrows_power, nrows, f1,f2,g1,g2,w1,w2);
- }
-
- Image_Transpose(Real_Array, Temp_Array, ncols, nrows); /* TRANSPOSE BACK: order of frequencies. */
- Image_Transpose(Imag_Array, Real_Array, ncols, nrows);
- C_Array_Copy(Temp_Array, Imag_Array, Length); /* THIS UNDOES THE SWITCHING IN ARG4,ARG5 */
- }
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg4;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg5;
- *Free++ = NIL;
- return answer;
-}
-\f
-Define_Primitive(Prim_Array_2D_FFT_2, 5, "ARRAY-2D-FFT-2!")
-{ long flag;
- Pointer answer;
- REAL *Real_Array, *Imag_Array;
- long Length, nrows, ncols;
-
- Primitive_5_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(nrows, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg3, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_4_Type(TC_ARRAY); /* real image */
- Arg_5_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- Sign_Extend(Arg1, flag); /* should be 1 or -1 */
- Length = Array_Length(Arg4);
- if (Length != (nrows*ncols)) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- if (Length != (Array_Length(Arg5))) Primitive_Error(ERR_ARG_5_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg4);
- Imag_Array = Scheme_Array_To_C_Array(Arg5);
- if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_5_WRONG_TYPE);
-
- C_Array_2D_FFT_In_Scheme_Heap(flag, nrows, ncols, Real_Array, Imag_Array);
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg4;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg5;
- *Free++ = NIL;
- return answer;
-}
-\f
-Define_Primitive(Prim_Array_3D_FFT, 6, "ARRAY-3D-FFT!")
-{ long flag;
- Pointer answer;
- REAL *Real_Array, *Imag_Array;
- long Length, ndeps, nrows, ncols;
-
- Primitive_6_Args();
- Arg_1_Type(TC_FIXNUM); /* flag */
- Range_Check(ndeps, Arg2, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(nrows, Arg3, 1, 512, ERR_ARG_2_BAD_RANGE);
- Range_Check(ncols, Arg4, 1, 512, ERR_ARG_3_BAD_RANGE);
- Arg_5_Type(TC_ARRAY); /* real image */
- Arg_6_Type(TC_ARRAY); /* imag image */
- Set_Time_Zone(Zone_Math); /* for timing */
-
- Sign_Extend(Arg1, flag); /* should be 1 or -1 */
- Length = Array_Length(Arg5);
- if (Length != (ndeps*nrows*ncols)) Primitive_Error(ERR_ARG_6_BAD_RANGE);
- if (Length != (Array_Length(Arg6))) Primitive_Error(ERR_ARG_6_BAD_RANGE);
- Real_Array = Scheme_Array_To_C_Array(Arg5);
- Imag_Array = Scheme_Array_To_C_Array(Arg6);
- if (Real_Array==Imag_Array) Primitive_Error(ERR_ARG_6_WRONG_TYPE);
-
- C_Array_3D_FFT_In_Scheme_Heap(flag, ndeps, nrows, ncols, Real_Array, Imag_Array);
-
- Primitive_GC_If_Needed(4); /* NOW RETURN ANSWERS */
- answer = Make_Pointer(TC_LIST, Free);
- *Free++ = Arg5;
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- *Free++ = Arg6;
- *Free++ = NIL;
- return answer;
-}
-
-/* END */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.22 1987/04/03 00:43:16 jinx Exp $
- *
- * This file contains hooks and handles for the new fluid bindings
- * scheme for multiprocessors.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "trap.h"
-#include "lookup.h"
-#include "locks.h"
-\f
-/* (SET-FLUID-BINDINGS! NEW-BINDINGS)
- Sets the microcode fluid-bindings variable. Returns the previous value.
-*/
-
-Define_Primitive(Prim_Set_Fluid_Bindings, 1, "SET-FLUID-BINDINGS!")
-{
- Pointer Result;
- Primitive_1_Arg();
-
- if (Arg1 != NIL)
- Arg_1_Type(TC_LIST);
-
- Result = Fluid_Bindings;
- Fluid_Bindings = Arg1;
- return Result;
-}
-
-/* (GET-FLUID-BINDINGS NEW-BINDINGS)
- Gets the microcode fluid-bindings variable.
-*/
-
-Define_Primitive(Prim_Get_Fluid_Bindings, 0, "GET-FLUID-BINDINGS")
-{
- Primitive_0_Args();
-
- return Fluid_Bindings;
-}
-
-/* (WITH-SAVED-FLUID-BINDINGS THUNK)
- Executes THUNK, then restores the previous fluid bindings.
-*/
-
-Define_Primitive(Prim_With_Saved_Fluid_Bindings,1,"WITH-SAVED-FLUID-BINDINGS")
-{
- Primitive_1_Arg();
-
- Pop_Primitive_Frame(1);
-
- /* Save previous fluid bindings for later restore */
-
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Expression(Fluid_Bindings);
- Store_Return(RC_RESTORE_FLUIDS);
- Save_Cont();
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
-}
-\f
-/* Utilities for the primitives below. */
-
-Pointer
-*lookup_slot(env, var)
-{
- Pointer *cell, *hunk, value;
- long trap_kind;
-
- hunk = Get_Pointer(var);
- lookup(cell, env, hunk, repeat_slot_lookup);
-
- value = Fetch(cell[0]);
-
- if (Type_Code(value) != TC_REFERENCE_TRAP)
- {
- return cell;
- }
-
- get_trap_kind(trap_kind, value);
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- return deep_lookup(env, hunk[VARIABLE_SYMBOL], hunk);
-
- case TRAP_FLUID:
- case TRAP_UNBOUND:
- case TRAP_UNASSIGNED:
- return cell;
-
- default:
- Primitive_Error(ERR_BROKEN_COMPILED_VARIABLE);
- }
-}
-\f
-Pointer
-new_fluid_binding(cell, value, force)
- Pointer *cell;
- Pointer value;
- Boolean force;
-{
- fast Pointer trap;
- Lock_Handle set_serializer;
- Pointer new_trap_value;
- long new_trap_kind, trap_kind;
-
- setup_lock(set_serializer, cell);
-
- new_trap_kind = TRAP_FLUID;
- trap = *cell;
- new_trap_value = trap;
-
- if (Type_Code(trap) == TC_REFERENCE_TRAP)
- {
- get_trap_kind(trap_kind, trap);
- switch(trap_kind)
- {
- case TRAP_DANGEROUS:
- Vector_Set(trap,
- TRAP_TAG,
- Make_Unsigned_Fixnum(TRAP_FLUID_DANGEROUS));
-
- /* Fall through */
- case TRAP_FLUID:
- case TRAP_FLUID_DANGEROUS:
- new_trap_kind = TRAP_NOP;
- break;
-\f
- case TRAP_UNBOUND:
- case TRAP_UNBOUND_DANGEROUS:
- if (!force)
- {
- remove_lock(set_serializer);
- Primitive_Error(ERR_UNBOUND_VARIABLE);
- }
- /* Fall through */
- case TRAP_UNASSIGNED:
- case TRAP_UNASSIGNED_DANGEROUS:
- new_trap_kind = Make_Unsigned_Fixnum((TRAP_FLUID | (trap_kind & 1)));
- new_trap_value = UNASSIGNED_OBJECT;
- break;
-
- default:
- remove_lock(set_serializer);
- Primitive_Error(ERR_BROKEN_COMPILED_VARIABLE);
- }
- }
-
- if (new_trap_kind != TRAP_NOP)
- {
- if (GC_allocate_test(2))
- {
- remove_lock(set_serializer);
- Primitive_GC(2);
- }
- trap = Make_Pointer(TC_REFERENCE_TRAP, Free);
- *Free++ = new_trap_kind;
- *Free++ = new_trap_value;
- *cell = trap;
- }
- remove_lock(set_serializer);
-
- /* Fluid_Bindings is per processor private. */
-
- Primitive_GC_If_Needed(4);
- Free[CONS_CAR] = Make_Pointer(TC_LIST, (Free + 2));
- Free[CONS_CDR] = Fluid_Bindings;
- Fluid_Bindings = Make_Pointer(TC_LIST, Free);
- Free += 2;
- Free[CONS_CAR] = trap;
- Free[CONS_CDR] = value;
- Free += 2;
-
- return NIL;
-}
-\f
-/* (ADD-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
- Looks up symbol-or-variable in environment. If it has not been
- fluidized, fluidizes it. A fluid binding with the specified
- value is created in this interpreter's fluid bindings.
-*/
-
-Define_Primitive(Prim_Add_Fluid_Binding, 3, "ADD-FLUID-BINDING!")
-{
- Pointer *cell;
- Primitive_3_Args();
-
- if (Arg1 != GLOBAL_ENV)
- Arg_1_Type(TC_ENVIRONMENT);
-
- switch (Type_Code(Arg2))
- {
- case TC_VARIABLE:
- cell = lookup_slot(Arg1, Arg2);
- break;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- cell = deep_lookup(Arg1, Arg2, fake_variable_object);
- break;
-
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
-
- return new_fluid_binding(cell, Arg3, false);
-}
-\f
-/* (MAKE-FLUID-BINDING! ENVIRONMENT SYMBOL-OR-VARIABLE VALUE)
- Looks up symbol-or-variable in environment. If it has not been
- fluidized, fluidizes it. A fluid binding with the specified
- value is created in this interpreter's fluid bindings. Unlike
- ADD-FLUID-BINDING!, it is not an error to discover no binding
- for this variable; a fluid binding will be made anyway. This is
- simple in the global case, since there is always a value slot
- available in the symbol itself. If the last frame searched
- in the environment chain is closed (does not have a parent
- and does not allow search of the global environment), an AUX
- binding must be established in the last frame.
-*/
-
-Define_Primitive(Prim_Make_Fluid_Binding, 3, "MAKE-FLUID-BINDING!")
-{
- Pointer *cell;
- fast Pointer env, previous;
- Primitive_3_Args();
-
- if (Arg1 != GLOBAL_ENV)
- Arg_1_Type(TC_ENVIRONMENT);
-
- switch (Type_Code(Arg2))
- {
- case TC_VARIABLE:
- cell = lookup_slot(Arg1, Arg2);
- break;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- cell = deep_lookup(Arg1, Arg2, fake_variable_object);
- break;
-
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
-\f
- /* This only happens when global is not allowed,
- it's expensive and will not be used, but is
- provided for completeness.
- */
-
- if (cell == unbound_trap_object)
- {
- long result;
- Pointer symbol;
-
- env = Arg1;
- if (Type_Code(env) == GLOBAL_ENV)
- Primitive_Error(ERR_BAD_FRAME);
-
- do
- {
- previous = env;
- env = Fast_Vector_Ref(Vector_Ref(env, ENVIRONMENT_FUNCTION),
- PROCEDURE_ENVIRONMENT);
- } while (Type_Code(env) != GLOBAL_ENV);
-
- symbol = ((Type_Code(Arg2) == TC_VARIABLE) ?
- Vector_Ref(Arg2, VARIABLE_SYMBOL) :
- Arg2);
-
- result = Local_Set(previous, symbol, UNASSIGNED_OBJECT);
- if (result != PRIM_DONE)
- {
- if (result == PRIM_INTERRUPT)
- Primitive_Interrupt();
-
- Primitive_Error(result);
- }
- cell = deep_lookup(previous, symbol, fake_variable_object);
- }
-
- return new_fluid_binding(cell, Arg3, true);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.24 1987/04/17 00:04:05 jinx Exp $
- *
- * Preprocessor to find and declare defined primitives.
- *
- */
-\f
-/*
- * This program searches for a particular token which tags primitive
- * definitions. This token is also a macro defined in primitive.h.
- * For each macro invocation it creates an entry in the External
- * Primitives descriptor used by Scheme. The entry consists of the C
- * routine implementing the primitive, the (fixed) number of arguments
- * it requires, and the name Scheme uses to refer to it.
- *
- * The output is a C source file to be compiled and linked with the
- * Scheme microcode.
- *
- * This program understands the following options (must be given in
- * this order):
- *
- * -o fname
- * Put the output file in fname. The default is to put it on the
- * standard output.
- *
- * -b n
- * Produce the built-in primitive table instead. The table should
- * have size n (in hex).
- *
- * Note that some output lines are done in a strange fashion because
- * some C compilers (the vms C compiler, for example) remove comments
- * even from within string quotes!!
- *
- */
-\f
-/* Some utility imports and definitions. */
-
-#include <stdio.h>
-
-/* For macros toupper, isalpha, etc,
- supposedly on the standard library.
-*/
-
-#include <ctype.h>
-
-extern int strcmp(), strlen();
-
-typedef int boolean;
-#define TRUE 1
-#define FALSE 0
-
-#ifdef vms
-/* VMS version 3 has no void. */
-/* #define void */
-#define normal_exit() return
-#else
-#define normal_exit() exit(0)
-#endif
-
-/* The 4.2 bsd vax compiler has a bug which forces the following. */
-
-#define pseudo_void int
-
-#define error_exit(do_it) \
-{ \
- if (do_it) \
- dump(TRUE); \
- exit(1); \
-}
-\f
-#ifdef DEBUGGING
-#define dprintf(one, two) fprintf(stderr, one, two)
-#else
-#define dprintf(one, two)
-#endif
-
-/* Maximum number of primitives that can be handled. */
-
-#ifndef BUFFER_SIZE
-#define BUFFER_SIZE 0x400
-#endif
-
-static boolean Built_in_p;
-static long Built_in_table_size;
-
-static char *The_Token;
-static char Built_in_Token[] = "Built_In_Primitive";
-static char External_Token[] = "Define_Primitive";
-
-static char *The_Table;
-static char Built_in_Table[] = "Primitive";
-static char External_Table[] = "External";
-
-static char *The_Variable;
-static char Built_in_Variable[] = "MAX_PRIMITIVE";
-static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE";
-
-static FILE *input, *output;
-static char *name;
-static char *file_name;
-
-static pseudo_void (*create_entry)();
-\f
-main(argc, argv)
- int argc;
- char *argv[];
-{
- void process(), sort(), dump();
- FILE *fopen();
-
- name = argv[0];
-
- /* Check for specified output file */
-
- if ((argc >= 2) && (strcmp("-o", argv[1]) == 0))
- {
- if ((output = fopen(argv[2], "w")) == NULL)
- {
- fprintf(stderr, "Error: %s can't open %s\n", name, argv[2]);
- error_exit(FALSE);
- }
- argv += 2;
- argc -= 2;
- }
- else
- output = stdout;
-
- /* Check whether to produce the built-in table instead.
- The argument after the option letter is the size of the
- table to build.
- */
-
- if ((argc >= 2) && (strcmp("-b", argv[1]) == 0))
- {
- void initialize_builtin();
-
- initialize_builtin(argv[2]);
- argv += 2;
- argc -= 2;
- }
- else
- {
- void initialize_external();
-
- initialize_external();
- }
-\f
- /* Check whether there are any files left. */
-
- if (argc == 1)
- {
- dump(FALSE);
- normal_exit();
- }
-
- while (--argc > 0)
- {
- file_name = *++argv;
- if (strcmp("-", file_name)==0)
- {
- input = stdin;
- file_name = "stdin";
- dprintf("About to process %s\n", "STDIN");
- process();
- }
- else if ((input = fopen(file_name, "r")) == NULL)
- {
- fprintf(stderr, "Error: %s can't open %s\n", name, file_name);
- error_exit(TRUE);
- }
- else
- {
- dprintf("About to process %s\n", file_name);
- process();
- fclose(input);
- }
- }
- dprintf("About to sort %s\n", "");
- sort();
- dprintf("About to dump %s\n", "");
- dump(TRUE);
- if (output != stdout)
- fclose(output);
- normal_exit();
-}
-\f
-#define DONE 0
-#define FOUND 1
-
-/* Search for tokens and when found, create primitive entries. */
-
-void
-process()
-{
- int scan();
-
- while ((scan() != DONE))
- {
- dprintf("Process: place found.%s\n", "");
- (*create_entry)();
- }
- return;
-}
-
-/* Search for token and stop when found. If you hit open comment
- * character, read until you hit close comment character.
- * *** FIX *** : It is not a complete C parser, thus it may be fooled,
- * currently the token must always begin a line.
-*/
-
-int
-scan()
-{
- register char c, *temp;
-
- c = '\n';
- while(c != EOF)
- {
- switch(c)
- { case '/':
- if ((c = getc(input)) == '*')
- {
- c = getc(input);
- while (TRUE)
- { while (c != '*')
- { if (c == EOF)
- { fprintf(stderr,
- "Error: EOF in comment in file %s, or %s confused\n",
- file_name, name);
- error_exit(TRUE);
- }
- c = getc(input);
- }
- if ((c = getc(input)) == '/') break;
- }
- }
- else if (c != '\n') break;
-
- case '\n':
- temp = &The_Token[0];
- while ((c = getc(input)) == *temp++) {}
- if (temp[-1] == '\0') return FOUND;
- ungetc(c, input);
- break;
-
- default: {}
- }
- c = getc(input);
- }
- return DONE;
-}
-\f
-boolean
-whitespace(c)
- char c;
-{
- switch(c)
- { case ' ':
- case '\t':
- case '\n':
- case '(':
- case ')':
- case ',': return TRUE;
- default: return FALSE;
- }
-}
-
-void
-scan_to_token_start()
-{
- char c;
-
- while (whitespace(c = getc(input))) {};
- ungetc(c, input);
- return;
-}
-
-/* *** FIX *** This should check for field overflow (n too small) */
-
-void
-copy_token(s, cap, Size)
- char s[];
- boolean cap;
- int *Size;
-{
- register char c;
- register int n = 0;
-
- while (!(whitespace(c = getc(input))))
- s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
- s[n] = '\0';
- if (n > *Size)
- *Size = n;
- return;
-}
-
-void
-copy_string(is, s, cap, Size)
- register char *is;
- char s[];
- boolean cap;
- int *Size;
-{
- register char c;
- register int n = 0;
-
- while ((c = *is++) != '\0')
- s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
- s[n] = '\0';
- if (n > *Size)
- *Size = n;
- return;
-}
-\f
-#define STRING_SIZE 80
-#define ARITY_SIZE 6
-
-typedef struct dsc
-{ char C_Name[STRING_SIZE]; /* The C name of the function */
- char Arity[ARITY_SIZE]; /* Number of arguments */
- char Scheme_Name[STRING_SIZE]; /* Scheme name of the primitive */
- char File_Name[STRING_SIZE]; /* File where found. */
-} descriptor;
-
-/*
- * *** FIX ***
- * This should really be malloced incrementally, but for the time being ...
- *
- */
-
-static int buffer_index = 0;
-descriptor Data_Buffer[BUFFER_SIZE];
-descriptor *Result_Buffer[BUFFER_SIZE];
-
-static descriptor Dummy_Entry =
-{ "Dummy_Primitive",
- "0",
- "\"DUMMY-PRIMITIVE\"",
- "Findprim.c"
-};
-
-static char Dummy_Error_String[] =
- "Microcode_Termination(TERM_BAD_PRIMITIVE)";
-
-static descriptor Inexistent_Entry =
-{ "Prim_Inexistent",
- "0",
- "No_Name",
- "Findprim.c"
-};
-
-static char Inexistent_Real_Name[] =
- "\"INEXISTENT-PRIMITIVE\"";
-static char Inexistent_Error_String[] =
- "Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)";
-
-static int C_Size = 0;
-static int A_Size = 0;
-static int S_Size = 0;
-static int F_Size = 0;
-
-#define DONT_CAP FALSE
-#define DO_CAP TRUE
-\f
-pseudo_void
-create_external_entry()
-{
- if (buffer_index >= BUFFER_SIZE)
- {
- fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
- fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
- name, BUFFER_SIZE);
- error_exit(FALSE);
- }
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
- Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
- buffer_index++;
- return;
-}
-
-void
-initialize_external()
-{
- Built_in_p = FALSE;
- The_Token = &External_Token[0];
- The_Table = &External_Table[0];
- The_Variable = &External_Variable[0];
- create_entry = create_external_entry;
- return;
-}
-
-void
-initialize_from_entry(entry)
- descriptor *entry;
-{
- C_Size = strlen(entry->C_Name);
- A_Size = strlen(entry->Arity);
- S_Size = strlen(entry->Scheme_Name);
- F_Size = strlen(entry->File_Name);
- return;
-}
-\f
-int
-read_index(arg)
- char *arg;
-{
- int result = 0;
-
- if ((arg[0] == '0') && (arg[1] == 'x'))
- sscanf(&arg[2], "%x", &result);
- else
- sscanf(&arg[0], "%d", &result);
- return result;
-}
-
-pseudo_void
-create_builtin_entry()
-{
- static char index_buffer[STRING_SIZE];
- int index = 0;
-
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
- scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
- scan_to_token_start();
- copy_token(index_buffer, DONT_CAP, &index);
- index = read_index(index_buffer);
- if (index >= Built_in_table_size)
- {
- fprintf(stderr, "%s: Table size = %d; Found Primitive %d.\n",
- name, Built_in_table_size, index);
- error_exit(FALSE);
- }
- if (Result_Buffer[index] != &Inexistent_Entry)
- {
- void print_entry(), initialize_index_size();
-
- fprintf(stderr, "%s: redefinition of primitive %d.\n", name, index);
- fprintf(stderr, "previous definition:\n");
- initialize_index_size();
- output = stderr,
- print_entry(index, Result_Buffer[index]);
- fprintf(stderr, "\n");
- fprintf(stderr, "new definition:\n");
- print_entry(index, &Data_Buffer[buffer_index]);
- fprintf(stderr, "\n");
- error_exit(FALSE);
- }
- Result_Buffer[index] = &Data_Buffer[buffer_index];
- buffer_index++;
- return;
-}
-
-void
-initialize_builtin(arg)
- char *arg;
-{
- register int index;
-
- Built_in_p = TRUE;
- Built_in_table_size = read_index(arg);
- if (Built_in_table_size > BUFFER_SIZE)
- {
- fprintf(stderr, "%s: built_in_table_size > BUFFER_SIZE.\n", name);
- fprintf(stderr, "Recompile with a larger value of BUFFER_SIZE.\n");
- error_exit(FALSE);
- }
- The_Token = &Built_in_Token[0];
- The_Table = &Built_in_Table[0];
- The_Variable = &Built_in_Variable[0];
- create_entry = create_builtin_entry;
- for (index = Built_in_table_size; --index >= 0; )
- Result_Buffer[index] = &Inexistent_Entry;
- initialize_from_entry(&Inexistent_Entry);
- return;
-}
-\f
-/* *** FIX *** No-op for now */
-
-void
-sort()
-{
- return;
-}
-\f
-static int max, max_index_size;
-static char index_buffer[STRING_SIZE];
-
-#define find_index_size(index, size) \
-{ \
- sprintf(index_buffer, "%x", (index)); \
- size = strlen(index_buffer); \
-}
-
-void
-initialize_index_size()
-{
- if (Built_in_p)
- max = Built_in_table_size;
- else
- max = buffer_index;
- find_index_size(max, max_index_size);
- max -= 1;
- return;
-}
-\f
-void
-print_spaces(how_many)
- register int how_many;
-{
- for(; --how_many >= 0;)
- putc(' ', output);
- return;
-}
-
-void
-print_entry(index, entry)
- int index;
- descriptor *entry;
-{
- int index_size;
-
- fprintf(output, " %s ", (entry->C_Name));
- print_spaces(C_Size - (strlen(entry->C_Name)));
- fprintf(output, "/%c ", '*');
- print_spaces(A_Size - (strlen(entry->Arity)));
- fprintf(output,
- "%s %s",
- (entry->Arity),
- (entry->Scheme_Name));
- print_spaces(S_Size-(strlen(entry->Scheme_Name)));
- fprintf(output, " %s ", ((Built_in_p) ? "Primitive" : "External"));
- find_index_size(index, index_size);
- print_spaces(max_index_size - index_size);
- fprintf(output, "0x%x in %s %c/", index, (entry->File_Name), '*');
- return;
-}
-
-void
-print_procedure(entry, error_string)
- descriptor *entry;
- char *error_string;
-{
- fprintf(output, "Pointer\n");
- fprintf(output, "%s()\n", (entry->C_Name));
- fprintf(output, "{\n");
- fprintf(output, " Primitive_%s_Args();\n", (entry->Arity));
- fprintf(output, "\n");
- fprintf(output, " %s;\n", error_string);
- fprintf(output, "}\n\n");
- return;
-}
-\f
-void
-print_primitives(last)
- register int last;
-{
-
- register int count;
-
- /* Print the procedure table. */
-
- fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Table);
-
- for (count = 0; count < last; count++)
- {
- print_entry(count, Result_Buffer[count]);
- fprintf(output, ",\n");
- }
- print_entry(last, Result_Buffer[last]);
- fprintf(output, "\n};\n\n");
-
- /* Print the arity table. */
-
- fprintf(output, "int %s_Arity_Table[] = {\n", The_Table);
-
- for (count = 0; count < last; count++)
- {
- fprintf(output, " %s,\n", ((Result_Buffer[count])->Arity));
- }
- fprintf(output, " %s\n", ((Result_Buffer[last])->Arity));
- fprintf(output, "};\n\n");
-
- /* Print the names table. */
-
- fprintf(output, "char *%s_Name_Table[] = {\n", The_Table);
-
- for (count = 0; count < last; count++)
- {
- fprintf(output, " %s,\n", ((Result_Buffer[count])->Scheme_Name));
- }
- fprintf(output, " %s\n", ((Result_Buffer[last])->Scheme_Name));
- fprintf(output, "};\n\n");
-
- return;
-}
-\f
-/* Produce C source. */
-
-void
-dump(check)
- boolean check;
-{
- register int count, end;
-
- initialize_index_size();
-
- /* Print header. */
-
- fprintf(output, "/%c Emacs: This is -*- C -*- code. %c/\n\n", '*', '*');
-
- fprintf(output, "/%c %s primitive declarations %c/\n\n",
- '*', ((Built_in_p) ? "Built in" : "User defined" ), '*');
-
- fprintf(output, "#include \"usrdef.h\"\n\n");
-
- fprintf(output, "long %s = %d;\n\n", The_Variable, max);
- if (Built_in_p)
- fprintf(output,
- "/%c The number of implemented primitives is %d. %c/\n\n",
- '*', buffer_index, '*');
-
- if (max < 0)
- {
- if (check)
- fprintf(stderr, "No primitives found!\n");
-
- /* C does not understand the empty array, thus it must be faked. */
-
- fprintf(output, "/%c C does not understand the empty array, ", '*');
- fprintf(output, "thus it must be faked. %c/\n\n", '*');
-
- /* Dummy entry */
-
- Result_Buffer[0] = &Dummy_Entry;
- initialize_from_entry(&Dummy_Entry);
- print_procedure(&Dummy_Entry, &Dummy_Error_String[0]);
-
- }
-\f
- else
- {
- /* Print declarations. */
-
- fprintf(output, "extern Pointer\n");
-
- end = (Built_in_p ? buffer_index : max);
- for (count = 0; count < end; count++)
- {
- fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]);
- }
-
- if (Built_in_p)
- {
- fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]);
-
- fprintf(output,
- "static char %s[] = %s;\n\n",
- Inexistent_Entry.Scheme_Name,
- Inexistent_Real_Name);
- print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
- }
- else
- fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]);
-
- }
-
- print_primitives((max < 0) ? 0 : max);
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.22 1987/04/16 02:22:24 jinx Exp $
- *
- * Support for fixed point arithmetic (24 bit). Mostly superceded
- * by generic arithmetic.
- */
-\f
-#include "scheme.h"
-#include "primitive.h"
-
- /***************************/
- /* UNARY FIXNUM OPERATIONS */
- /***************************/
-
-/* These operations return NIL if their argument is not a fixnum.
- Otherwise, they return the appropriate fixnum if the result is
- expressible as a fixnum. If the result is out of range, they
- return NIL.
-*/
-
-Built_In_Primitive(Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM", 0x42)
-{
- fast long A, Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Sign_Extend(Arg1, A);
- Result = A + 1;
- if (Fixnum_Fits(Result))
- return Make_Non_Pointer(TC_FIXNUM, Result);
- else
- return NIL;
-}
-
-Built_In_Primitive(Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM", 0x43)
-{
- fast long A, Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Sign_Extend(Arg1, A);
- Result = A - 1;
- if (Fixnum_Fits(Result))
- return Make_Non_Pointer(TC_FIXNUM, Result);
- else
- return NIL;
-}
-\f
- /****************************/
- /* BINARY FIXNUM PREDICATES */
- /****************************/
-
-/* Binary fixnum predicates return NIL if their argument is not a
- fixnum, 1 if the predicate is true, or 0 if the predicate is false.
-*/
-
-#define Binary_Predicate_Fixnum(Op) \
-{ \
- fast long A, B; \
- Primitive_2_Args(); \
- \
- Arg_1_Type(TC_FIXNUM); \
- Arg_2_Type(TC_FIXNUM); \
- Sign_Extend(Arg1, A); \
- Sign_Extend(Arg2, B); \
- return Make_Unsigned_Fixnum(((A Op B) ? 1 : 0)); \
-}
-
-Built_In_Primitive(Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?", 0x3F)
-{
- Binary_Predicate_Fixnum(==);
-}
-
-Built_In_Primitive(Prim_Greater_Fixnum, 2, "LESS-THAN-FIXNUM?", 0x40)
-{
- Binary_Predicate_Fixnum(>);
-}
-
-Built_In_Primitive(Prim_Less_Fixnum, 2, "GREATER-THAN-FIXNUM?", 0x81)
-{
- Binary_Predicate_Fixnum(<);
-}
-\f
- /****************************/
- /* BINARY FIXNUM OPERATIONS */
- /****************************/
-
-/* All binary fixnum operations take two arguments and return NIL if
- either is not a fixnum. If both arguments are fixnums and the
- result fits as a fixnum, then the result is returned. If the
- result will not fit as a fixnum, NIL is returned.
-*/
-
-#define Binary_Fixnum(Op) \
-{ \
- fast long A, B, Result; \
- Primitive_2_Args(); \
- \
- Arg_1_Type(TC_FIXNUM); \
- Arg_2_Type(TC_FIXNUM); \
- Sign_Extend(Arg1, A); \
- Sign_Extend(Arg2, B); \
- Result = A Op B; \
- if (Fixnum_Fits(Result)) \
- return Make_Non_Pointer(TC_FIXNUM, Result); \
- else \
- return NIL; \
-}
-
-Built_In_Primitive(Prim_Plus_Fixnum, 2, "PLUS-FIXNUM", 0x3B)
-{
- Binary_Fixnum(+);
-}
-
-Built_In_Primitive(Prim_Minus_Fixnum, 2, "MINUS-FIXNUM", 0x3C)
-{
- Binary_Fixnum(-);
-}
-
-Built_In_Primitive(Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM", 0x3D)
-{
- /* Mul, which does the multiplication with overflow handling is
- machine dependent. Therefore, it is in os.c
- */
- extern Pointer Mul();
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- return Mul(Arg1, Arg2);
-}
-\f
-Built_In_Primitive(Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM", 0x3E)
-{
-
- /* Returns the CONS of quotient and remainder */
- fast long A, B, Quotient, Remainder;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
- if (B == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Primitive_GC_If_Needed(2);
- Quotient = A/B;
- Remainder = A%B;
- if (Fixnum_Fits(Quotient))
- { Free[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, Quotient);
- Free[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, Remainder);
- Free += 2;
- return Make_Pointer(TC_LIST, Free-2);
- }
- return NIL;
-}
-
-Built_In_Primitive(Prim_Gcd_Fixnum, 2, "GCD-FIXNUM", 0x66)
-{
- /* Returns the Greatest Common Divisor */
- fast long A, B, C;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
- while (B != 0)
- { C = A;
- A = B;
- B = C % B;
- }
- return Make_Non_Pointer(TC_FIXNUM, A);
-}
-\f
-/* (NEGATIVE-FIXNUM? NUMBER)
- Returns NIL if NUMBER isn't a fixnum. Returns 0 if NUMBER < 0, 1
- if NUMBER >= 0.
-*/
-Built_In_Primitive(Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?", 0x7F)
-{
- long Value;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Sign_Extend(Arg1, Value);
- return Make_Unsigned_Fixnum(((Value < 0) ? 1 : 0));
-}
-
-/* (POSITIVE-FIXNUM? NUMBER)
- Returns 1 if NUMBER is a positive fixnum, 0 for other fixnums,
- or NIL.
-*/
-Built_In_Primitive(Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?", 0x41)
-{
- long Value;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Sign_Extend(Arg1, Value);
- return Make_Unsigned_Fixnum(((Value > 0) ? 1 : 0));
-}
-
-/* (ZERO-FIXNUM? NUMBER)
- Returns NIL if NUMBER isn't a fixnum. Otherwise, returns 0 if
- NUMBER is 0 or 1 if it is.
-*/
-Built_In_Primitive(Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?", 0x46)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- return Make_Unsigned_Fixnum(((Get_Integer(Arg1) == 0) ? 1 : 0));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $
- *
- * Declarations of user offsets into the Fixed Objects Vector.
- * This should correspond to the file UTABMD.SCM
- */
-\f
-#define Non_Object 0x00 /* Used for unassigned variables */
-#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
-#define System_Error_Vector 0x02 /* Handlers for errors */
-#define OBArray 0x03 /* Array for interning symbols */
-#define Types_Vector 0x04 /* Type number -> Name map */
-#define Returns_Vector 0x05 /* Return code -> Name map */
-#define Primitives_Vector 0x06 /* Primitive code -> Name map */
-#define Errors_Vector 0x07 /* Error code -> Name map */
-#define Identification_Vector 0x08 /* ID Vector index -> name map */
-#define GC_Daemon 0x0B /* Procedure to run after GC */
-#define Trap_Handler 0x0C /* Continue after disaster */
-#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
-#define Fixed_Objects_Slots 0x0F /* Names of these slots */
-#define External_Primitives 0x10 /* Names of external prims */
-#define State_Space_Tag 0x11 /* Tag for state spaces */
-#define State_Point_Tag 0x12 /* Tag for state points */
-#define Dummy_History 0x13 /* Empty history structure */
-#define Bignum_One 0x14 /* Cache for bignum one */
-#define System_Scheduler 0x15 /* Scheduler for touched futures */
-#define Termination_Vector 0x16 /* Names for terminations */
-#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
-#define Me_Myself 0x18 /* The actual shared vector */
-/* The next slot is used only in multiprocessor mode */
-#define The_Work_Queue 0x19 /* Where work is stored */
-/* These two slots are only used if logging futures */
-#define Future_Logger 0x1A /* Routine to log touched futures */
-#define Touched_Futures 0x1B /* Vector of touched futures */
-#define Precious_Objects 0x1C /* Objects that should not be lost! */
-#define Error_Procedure 0x1D /* User invoked error handler */
-#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
-#define Utilities_Vector 0x1F /* ??? */
-#define Compiler_Err_Procedure 0x20 /* ??? */
-#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
-#define State_Space_Root 0x22 /* Root of state space */
-
-#define NFixed_Objects 0x23
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.22 1987/04/16 02:22:34 jinx Rel $
- *
- * This file contains support for floating point arithmetic. Most
- * of these primitives have been superceded by generic arithmetic.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "flonum.h"
-#include "zones.h"
-\f
- /************************************/
- /* BINARY FLOATING POINT OPERATIONS */
- /************************************/
-
-/* The binary floating point operations return NIL if either argument
- is not a floating point number. Otherwise they return the
- appropriate result.
-*/
-
-Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM", 0x69)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(Get_Float(Arg1) + Get_Float(Arg2));
-}
-
-Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM", 0x6A)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(Get_Float(Arg1) - Get_Float(Arg2));
-}
-
-Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM", 0x6B)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2));
-}
-
-Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM", 0x6C)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- if (Get_Float(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
-}
-\f
- /************************************/
- /* BINARY FLOATING POINT PREDICATES */
- /************************************/
-
-/* The binary flonum predicates return NIL if either of the arguments
- is not a flonum. Otherwise, return a fixnum 1 if the predicate is
- true, or a fixnum 0 if it is false.
-*/
-
-Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?", 0x6D)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return
- Make_Unsigned_Fixnum(((Get_Float(Arg1)) == (Get_Float(Arg2))) ? 1 : 0);
-}
-
-Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-THAN-FLONUM?", 0xAA)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return
- Make_Unsigned_Fixnum(((Get_Float(Arg1)) > (Get_Float(Arg2))) ? 1 : 0);
-}
-
-Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-THAN-FLONUM?", 0x6E)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Arg_2_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return
- Make_Unsigned_Fixnum(((Get_Float(Arg1)) < (Get_Float(Arg2))) ? 1 : 0);
-}
-\f
- /***********************************/
- /* UNARY FLOATING POINT OPERATIONS */
- /***********************************/
-
-/* The unary flonum operations return NIL if their argument is
- not a flonum. Otherwise, they return the appropriate result.
-*/
-
-Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM", 0x73)
-{
- extern double sin();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(sin(Get_Float(Arg1)));
-}
-
-Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM", 0x74)
-{
- extern double cos();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(cos(Get_Float(Arg1)));
-}
-
-Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM", 0x75)
-{
- extern double atan();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(atan(Get_Float(Arg1)));
-}
-\f
-Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM", 0x76)
-{
- extern double exp();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Flonum_Result(exp(Get_Float(Arg1)));
-}
-
-Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM", 0x77)
-{
- extern double log();
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- if (Arg1 <= 0.0)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- Flonum_Result(log(Get_Float(Arg1)));
-}
-
-Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM", 0x78)
-{
- extern double sqrt();
- double Arg;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- Arg = Get_Float(Arg1);
- if (Arg < 0)
- return NIL;
- Flonum_Result(sqrt(Arg));
-}
-\f
-Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?", 0xA7)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return Make_Unsigned_Fixnum((Get_Float(Arg1) == 0.0) ? 1 : 0);
-}
-
-Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?", 0xA8)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return Make_Unsigned_Fixnum((Get_Float(Arg1) > 0.0) ? 1 : 0);
-}
-
-Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?", 0xA9)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- return Make_Unsigned_Fixnum((Get_Float(Arg1) < 0.0) ? 1 : 0);
-}
-\f
-/* (COERCE-INTEGER-TO-FLONUM FIXNUM-OR-BIGNUM)
- Returns the floating point number (flonum) corresponding to
- either a bignum or a fixnum. If the bignum is too large or small
- to be converted to floating point, or if the argument isn't of
- the correct type, FIXNUM-OR-BIGNUM is returned unchanged.
-*/
-Built_In_Primitive(Prim_Int_To_Float, 1, "COERCE-INTEGER-TO-FLONUM", 0x72)
-{
- Primitive_1_Arg();
-
- Set_Time_Zone(Zone_Math);
- if (Type_Code(Arg1)==TC_FIXNUM)
- {
- long Int;
-
- Sign_Extend(Arg1, Int);
- return Allocate_Float((double) Int);
- }
- if (Type_Code(Arg1) == TC_BIG_FIXNUM)
- return Big_To_Float(Arg1);
- return Arg1;
-}
-\f
-/* (TRUNCATE-FLONUM FLONUM)
- Returns the integer corresponding to FLONUM when truncated.
- Returns NIL if FLONUM isn't a floating point number
-*/
-Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM", 0x70)
-{
- fast double A;
- long Answer; /* Faulty VAX/UNIX C optimizer */
- Primitive_1_Arg();
-
- Arg_1_Type(TC_BIG_FLONUM);
- Set_Time_Zone(Zone_Math);
- A = Get_Float(Arg1);
- if (flonum_exceeds_fixnum(A))
- return Float_To_Big(A);
- Answer = (long) A;
- return Make_Non_Pointer(TC_FIXNUM, Answer);
-}
-
-/* (ROUND-FLONUM FLONUM)
- Returns the integer found by rounding off FLONUM (upward), if
- FLONUM is a floating point number. Otherwise returns FLONUM.
-*/
-Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM", 0x71)
-{
- fast double A;
- long Answer; /* Faulty VAX/UNIX C optimizer */
- Primitive_1_Arg();
-
- Set_Time_Zone(Zone_Math);
- if (Type_Code(Arg1) != TC_BIG_FLONUM) return Arg1;
- A = Get_Float(Arg1);
- if (A >= 0)
- A += 0.5;
- else
- A -= 0.5;
- if (flonum_exceeds_fixnum(A))
- return Float_To_Big(A);
- Answer = (long) A;
- return Make_Non_Pointer(TC_FIXNUM, Answer);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.22 1987/04/16 02:22:53 jinx Exp $
-
- Support code for futures
-*/
-
-#include "scheme.h"
-#include "primitive.h"
-#include "locks.h"
-\f
-#ifndef COMPILE_FUTURES
-#include "Error: future.c is useless without COMPILE_FUTURES"
-#endif
-
-/*
-
-A future is a VECTOR starting with <determined?>, <locked?> and
-<waiting queue / value>,
-
-where <determined?> is #!false if no value is known yet,
- #!true if value is known and future can vanish at GC,
- otherwise value is known, but keep the slot
-
-and where <locked> is #!true if someone wants slot kept for a time.
-
-*/
-\f
-Define_Primitive(Prim_Touch, 1, "TOUCH")
-{ Pointer Result;
- Primitive_1_Arg();
- Touch_In_Primitive(Arg1, Result);
- return Result;
-}
-
-Define_Primitive(Prim_Future_P, 1, "FUTURE?")
-{ Primitive_1_Arg();
- return (Type_Code(Arg1) == TC_FUTURE) ? TRUTH : NIL;
-}
-\f
-/* Utility setting routine for use by the various test and set if
- equal operators.
-*/
-
-long Set_If_Equal(Base, Offset, New, Wanted)
-Pointer Base, Wanted, New;
-long Offset;
-{ Lock_Handle lock;
- Pointer Old_Value, Desired, Remember_Value;
- long success;
-
- Touch_In_Primitive(Wanted, Desired);
-Try_Again:
- Remember_Value = Vector_Ref(Base, Offset);
- Touch_In_Primitive(Remember_Value, Old_Value);
- lock = Lock_Cell(Nth_Vector_Loc(Base, Offset));
- if (Remember_Value != Fast_Vector_Ref(Base, Offset))
- { Unlock_Cell(lock);
- goto Try_Again;
- }
- if (Old_Value == Desired)
- { Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New);
- success = true;
- }
- else success = false;
- Unlock_Cell(lock);
- return success;
-}
-
-Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!")
-/* (SET-CAR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
- Replaces the CAR of <CONS Cell> with <New Value> if it used to contain
- <Old Value>. The value returned is either <CONS Cell> (if the modification
- takes place) or '() if it does not.
-*/
-{ Primitive_3_Args();
- Arg_1_Type(TC_LIST);
- if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) return Arg1;
- else return NIL;
-}
-\f
-Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!")
-/* (SET-CDR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
- Replaces the CDR of <CONS Cell> with <New Value> if it used to contain
- <Old Value>. The value returned is either <CONS Cell> (if the modification
- takes place) or '() if it does not.
-*/
-{ Primitive_3_Args();
- Arg_1_Type(TC_LIST);
- if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) return Arg1;
- else return NIL;
-}
-
-Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!")
-/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
- Replaces the <Offset>th element of <Vector> with <New Value> if it used
- to contain <Old Value>. The value returned is either <Vector> (if
- the modification takes place) or '() if it does not.
-*/
-{ long Offset;
- Primitive_4_Args();
- Arg_1_Type(TC_VECTOR);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2,
- 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
- else return NIL;
-}
-
-Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!")
-/* (SET-CXR-IF-EQ?! <Triple> <Offset> <New Value> <Old Value>)
- Replaces the <Offset>th CXR of <Triple> with <New Value> if it used to
- contain <Old Value>. The value returned is either <Triple> (if
- the modification takes place) or '() if it does not.
-*/
-{ Pointer Arg4;
- long Offset;
- Primitive_3_Args();
- Arg4 = Stack_Ref(3);
- Arg_1_Type(TC_HUNK3);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
- if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
- else return NIL;
-}
-\f
-Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF")
-/* (FUTURE-REF <Future> <Offset>)
- Returns the <Offset>th slot from the future object. This is
- the equivalent of SYSTEM-VECTOR-REF but works only on future
- objects and doesn't touch.
-*/
-{ long Offset;
- Primitive_2_Args();
- Arg_1_Type(TC_FUTURE);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2,
- 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- return User_Vector_Ref(Arg1, Offset);
-}
-
-Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!")
-/* (FUTURE-SET! <Future> <Offset> <New Value>)
- Modifies the <Offset>th slot from the future object. This is
- the equivalent of SYSTEM-VECTOR-SET! but works only on future
- objects and doesn't touch.
-*/
-{ long Offset;
- Pointer Result;
- Primitive_3_Args();
- Arg_1_Type(TC_FUTURE);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2,
- 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Result = User_Vector_Ref(Arg1, Offset);
- User_Vector_Set(Arg1, Offset,Arg3);
- return Result;
-}
-\f
-Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE")
-/* (FUTURE-SIZE <Future>)
- Returns the number of slots in the future object. This is
- the equivalent of SYSTEM-VECTOR-SIZE but works only on future
- objects and doesn't touch.
-*/
-{ Primitive_1_Arg();
- Arg_1_Type(TC_FUTURE);
- return Make_Unsigned_Fixnum(Vector_Length(Arg1));
-}
-
-Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!")
-/* (LOCK-FUTURE! <Future>)
- Sets the lock flag on the future object, so that it won't be
- spliced-out by the garbage collector. Returns #!false if the
- argument isn't a future (might have been determined in the
- interim), #!TRUE if it is a future. Hangs as long as necessary
- for the lock to take, since Scheme code operates while locked.
- Opposite of UNLOCK-FUTURE!.
-*/
-{ Primitive_1_Arg();
- if (Type_Code(Arg1) != TC_FUTURE) return NIL;
- while ((IntEnb & IntCode) == 0)
- if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK),
- TRUTH) == NIL)
- return TRUTH;
- else Sleep(CONTENTION_DELAY);
- Primitive_Interrupt();
-}
-
-Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!")
-/* (UNLOCK-FUTURE! <Future>)
- Clears the lock flag on a locked future object, otherwise nothing.
-*/
-{ Primitive_1_Arg();
- if (Type_Code(Arg1) != TC_FUTURE) return NIL;
- if (!Future_Is_Locked(Arg1))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE)
- else
- { Vector_Set(Arg1, FUTURE_LOCK, NIL);
- return TRUTH;
- };
-}
-\f
-Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR")
-/* (FUTURE->VECTOR <Future>)
- Create a COPY of <future> but with type code vector.
-*/
-{ Pointer Result = Make_Pointer(TC_VECTOR, Free);
- long Size, i;
- Primitive_1_Arg();
- if (Type_Code(Arg1) != TC_FUTURE) return NIL;
- Size = Vector_Length(Arg1);
- Primitive_GC_If_Needed(Size + 1);
- for (i=0; i <= Size; i++) *Free++ = Vector_Ref(Arg1, i);
- return Result;
-}
-
-Define_Primitive(Prim_Future_Eq, 2, "NON-TOUCHING-EQ?")
-{ Primitive_2_Args();
- return ((Arg1==Arg2) ? TRUTH : NIL);
-}
-
-/* MAKE-INITIAL-PROCESS is called to create a small stacklet which
- * will just call the specified thunk and then end the computation
- */
-
-Define_Primitive(Prim_Make_Initial_Process, 1, "MAKE-INITIAL-PROCESS")
-{ Pointer Result;
- long Useful_Length, Allocated_Length, Waste_Length;
- Primitive_1_Arg();
-
- Result = Make_Pointer(TC_CONTROL_POINT, Free);
- Useful_Length = 3*CONTINUATION_SIZE+STACK_ENV_EXTRA_SLOTS+1;
-#ifdef USE_STACKLETS
- if ((Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE) <
- Default_Stacklet_Size)
- Allocated_Length = Default_Stacklet_Size;
- else Allocated_Length =
- Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE;
- Primitive_GC_If_Needed(Allocated_Length+1);
- Waste_Length = (Allocated_Length-Useful_Length-STACKLET_HEADER_SIZE)+1;
- Free[STACKLET_LENGTH] =
- Make_Pointer(TC_MANIFEST_VECTOR, Allocated_Length);
- Free[STACKLET_UNUSED_LENGTH] =
- DANGER_BIT | (Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
- Waste_Length));
- Free += Allocated_Length-Useful_Length+1;
-#else
- Free[STACKLET_LENGTH] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR,
- Useful_Length + STACKLET_HEADER_SIZE - 1);
- Free[STACKLET_UNUSED_LENGTH] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
- Free += STACKLET_HEADER_SIZE;
-#endif
-/* Make_Initial_Process continues on the next page */
-\f
-/* Make_Initial_Process continued */
-
- Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb);
- Free[CONTINUATION_RETURN_CODE] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_INT_MASK);
- Free += CONTINUATION_SIZE;
- Free[CONTINUATION_EXPRESSION] = NIL;
- Free[CONTINUATION_RETURN_CODE] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_INTERNAL_APPLY);
- Free += CONTINUATION_SIZE;
- *Free++ = STACK_FRAME_HEADER;
- *Free++ = Arg1;
- Free[CONTINUATION_EXPRESSION] = Arg1; /* For testing & debugging */
- Free[CONTINUATION_RETURN_CODE] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_END_OF_COMPUTATION);
- Free += CONTINUATION_SIZE;
- return Result;
-}
-\f
-/*
- Absolutely the cheapest future we can make. This includes
- the I/O stuff and whatnot. Notice that the name is required.
-
- (make-cheap-future orig-code user-proc name)
-
-*/
-
-Define_Primitive(Prim_Make_Cheap_Future, 3, "MAKE-CHEAP-FUTURE")
-{ Pointer The_Future;
- Pointer IO_Vector, IO_Cons, IO_Hunk3, Empty_Queue, IO_String;
- Primitive_3_Args();
-
- Primitive_GC_If_Needed(21);
-
- Empty_Queue=Make_Pointer(TC_LIST,Free);
- *Free++=NIL;
- *Free++=NIL;
-
- IO_String=Make_Pointer(TC_CHARACTER_STRING,Free);
- *Free++=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1);
- *Free++=Make_Unsigned_Fixnum(0);
-
- IO_Cons=Make_Pointer(TC_LIST,Free);
- *Free++=Make_Unsigned_Fixnum(0);
- *Free++=IO_String;
-
- IO_Hunk3=Make_Pointer(TC_HUNK3,Free);
- *Free++=NIL;
- *Free++=Arg3;
- *Free++=IO_Cons;
-
- IO_Vector=Make_Pointer(TC_VECTOR,Free);
- *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,1);
- *Free++=IO_Hunk3;
-
- The_Future=Make_Pointer(TC_FUTURE,Free);
- *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,10);
- *Free++=NIL; /* No value yet. */
- *Free++=NIL; /* Not locked. */
- *Free++=Empty_Queue; /* Put the empty queue here. */
- *Free++=Arg1; /* The process slot. */
- *Free++=TRUTH; /* Status slot. */
- *Free++=Arg2; /* Original code. */
- *Free++=IO_Vector; /* Put the I/O system stuff here. */
- *Free++=NIL; /* Waiting on list. */
- *Free++=New_Future_Number(); /* Metering number. */
- *Free++=NIL; /* User data slot */
-
- return The_Future; }
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.21 1987/01/22 14:26:05 jinx Exp $
- *
- * This file contains macros useful for dealing with futures
- */
-\f
-/* Data structure definition */
-
-/* The IS_DETERMINED slot has one of the following type of values:
- * #!FALSE if the value is not yet known
- * #!TRUE if the value is known and the garbage collector is free
- * to remove the future object in favor of its value everywhere
- * else the value is known, but the GC must leave the future object
-*/
-
-#define FUTURE_VECTOR_HEADER 0
-#define FUTURE_IS_DETERMINED 1
-#define FUTURE_LOCK 2
-#define FUTURE_VALUE 3 /* if known, else */
-#define FUTURE_QUEUE 3 /* tasks waiting for value */
-#define FUTURE_EXTRA_STUFF 4 /* rest for extensibility */
-\f
-#define Future_Is_Locked(P) \
- (Vector_Ref((P), FUTURE_LOCK) != NIL)
-
-#define Future_Has_Value(P) \
- (Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL)
-
-#define Future_Value(P) \
- Vector_Ref((P), FUTURE_VALUE)
-
-#define Future_Spliceable(P) \
- ((Vector_Ref((P), FUTURE_IS_DETERMINED) == TRUTH) && \
- (Vector_Ref((P), FUTURE_LOCK) == NIL))
-
-#define Future_Is_Keep_Slot(P) \
-((Vector_Ref((P), FUTURE_IS_DETERMINED) != NIL) && \
- (Vector_Ref((P), FUTURE_IS_DETERMINED) != TRUTH))
-
-#ifdef COMPILE_FUTURES
-/* Touch_In_Primitive is used by primitives which are not
- * strict in an argument but which touch it none the less.
- */
-
-#define Touch_In_Primitive(P, To_Where) \
-{ Pointer Value = (P); \
- while (Type_Code(Value) == TC_FUTURE) \
- { if (Future_Has_Value(Value)) \
- { if (Future_Is_Keep_Slot(Value)) Log_Touch_Of_Future(Value);\
- Value = Future_Value(Value); \
- } \
- else \
- { Back_Out_Of_Primitive(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Save_Cont(); \
- Push(Value); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- longjmp(*Back_To_Eval, PRIM_APPLY); \
- } \
- } \
- To_Where = Value; \
-}
-\f
-/* NOTES ON FUTURES, derived from the rest of the interpreter code */
-
-/* ASSUMPTION: The syntaxer is hereby assumed NEVER to generate primitive
- combinations unless the primitive itself is output in the code stream.
- Therefore, we don't have to explicitly check here that the expression
- register has a primitive in it.
-
- ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor
- do the cached lexical address slots.
-
- ASSUMPTION: Compiled code calls to the interpreter require the results
- be touched before returning to the compiled code. This may be very wrong.
-
- ASSUMPTION: History objects are never created using futures.
-
- ASSUMPTION: State points, which are created only by the interpreter,
- never contain FUTUREs except possibly as the thunks (which are handled
- by the apply code).
-
-*/
-
-/* OPTIMIZATIONS (?):
- After a lot of discussion, we decided that variable reference will check
- whether a value stored in the environment is a determined future which
- is marked spliceable. If so, it will splice out the future from the
- environment slot to speed up subsequent references.
-
- EQ? does a normal identity check and only if this fails does it touch the
- arguments. The same thing does not speed up MEMQ or ASSQ in the normal
- case, so it is omitted there.
-
- The following are NOT done, but might be useful later
- (1) Splicing on SET! operations
- (2) Splicing at apply and/or primitive apply
- (3) Splicing all arguments when a primitive errors on any of them
- (4) Splicing within the Arg_n_Type macro rather than after longjmping
- to the error handler.
-*/
-
-/* KNOWN PROBLEMS:
- (1) Garbage collector should be modified to splice out futures.
-
- (2) Purify should be looked at and we should decide what to do about
- purifying an object with a reference to a future (it should probably
- become constant but not pure).
-
- (3) Look at Impurify and Side-Effect-Impurify to see if futures
- affect them in any way.
-*/
-\f
-#ifdef FUTURE_LOGGING
-#define Touched_Futures_Vector() Get_Fixed_Obj_Slot(Touched_Futures)
-
-#define Logging_On() \
-(Valid_Fixed_Obj_Vector() && Touched_Futures_Vector())
-
-/* Log_Touch_Of_Future adds the future which was touched to the vector
- of touched futures about which the scheme portion of the system has
- not yet been informed
-*/
-#define Log_Touch_Of_Future(F) \
-if (Logging_On()) \
-{ Pointer TFV = Touched_Futures_Vector(); \
- long Count = Get_Integer(User_Vector_Ref(TFV, 0))+1; \
- User_Vector_Ref(TFV, 0) = FIXNUM_0 + Count; \
- if (Count < Vector_Length(TFV)) \
- User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \
-}
-
-/* Call_Future_Logging calls a user defined scheme routine if the vector
- of touched futures has a nonzero length.
-*/
-#define Must_Report_References() \
-( Logging_On() && \
- (Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0))
-
-#define Call_Future_Logging() \
-{ \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
- Push(Touched_Futures_Vector()); \
- Push(Get_Fixed_Obj_Slot(Future_Logger)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- Touched_Futures_Vector() = NIL; \
- goto Apply_Non_Trapping; \
-}
-#else
-#define Log_Touch_Of_Future(F) { }
-#define Call_Future_Logging()
-#define Must_Report_References() (false)
-#endif /* Logging */
-
-#else /* Futures not compiled */
-#define Touch_In_Primitive(P, To_Where) To_Where = (P)
-#define Log_Touch_Of_Future(F) { }
-#define Call_Future_Logging()
-#define Must_Report_References() (false)
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.22 1987/04/03 00:13:13 jinx Rel $
- *
- * Garbage collection related macros of sufficient utility to be
- * included in all compilations.
- */
-\f
-/* GC Types. */
-
-#define GC_Non_Pointer 0
-#define GC_Cell 1
-#define GC_Pair 2
-#define GC_Triple 3
-#define GC_Hunk3 3
-#define GC_Quadruple 4
-#define GC_Hunk4 4
-#define GC_Undefined -1 /* Undefined types */
-#define GC_Special -2 /* Internal GC types */
-#define GC_Vector -3
-#define GC_Compiled -4
-
-#define GC_Type_Code(TC) \
- ((GC_Type_Map[TC] != GC_Undefined) ? \
- GC_Type_Map[TC] : \
- (fprintf(stderr, "Bad Type code = 0x%02x\n", TC), \
- Invalid_Type_Code(), GC_Undefined))
-
-#define GC_Type(Object) GC_Type_Code(Safe_Type_Code(Object))
-
-#define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer)
-#define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell)
-#define GC_Type_List(Object) (GC_Type(Object) == GC_Pair)
-#define GC_Type_Triple(Object) (GC_Type(Object) == GC_Triple)
-#define GC_Type_Quadruple(Object) (GC_Type(Object) == GC_Quadruple)
-#define GC_Type_Undefined(Object) (GC_Type(Object) == GC_Undefined)
-#define GC_Type_Special(Object) (GC_Type(Object) == GC_Special)
-#define GC_Type_Vector(Object) (GC_Type(Object) == GC_Vector)
-#define GC_Type_Compiled(Object) (GC_Type(Object) == GC_Compiled)
-
-#define Invalid_Type_Code() \
- Microcode_Termination(TERM_INVALID_TYPE_CODE)
-\f
-/* Overflow detection, various cases */
-
-#define GC_Check(Amount) (((Amount+Free) >= MemTop) && \
- ((IntEnb & INT_GC) != 0))
-
-#define Space_Before_GC() (((IntEnb & INT_GC) != 0) ? \
- (MemTop - Free) : \
- (Heap_Top - Free))
-
-#define Request_Interrupt(code) \
-{ \
- IntCode |= (code); \
- New_Compiler_MemTop(); \
-}
-
-#define Request_GC(Amount) \
-{ \
- Request_Interrupt( INT_GC); \
- GC_Space_Needed = Amount; \
-}
-
-#define Set_Mem_Top(Addr) \
- MemTop = Addr; New_Compiler_MemTop()
-
-#define Set_Stack_Guard(Addr) Stack_Guard = Addr
-
-#define New_Compiler_MemTop() \
- Regs[REGBLOCK_MEMTOP] = \
- ((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1)
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.23 1987/04/16 02:23:06 jinx Exp $
- *
- * This file contains the macros for use in code which does GC-like
- * loops over memory. It is only included in a few files, unlike
- * GC.H which contains general purpose macros and constants.
- *
- */
-\f
-/* A SWITCH on GC types, duplicates information in GC_Type_Map[], but exists
- for efficiency reasons. Macros must be used by convention: first
- Switch_by_GC_Type, then each of the case_ macros (in any order). The
- default: case MUST be included in the switch.
-*/
-
-#define Switch_by_GC_Type(P) \
- switch(Safe_Type_Code(P))
-
-#define case_simple_Non_Pointer \
- case TC_NULL: \
- case TC_TRUE: \
- case TC_THE_ENVIRONMENT: \
- case TC_RETURN_CODE: \
- case TC_PRIMITIVE: \
- case TC_PCOMB0: \
- case TC_STACK_ENVIRONMENT
-
-#define case_Fasdump_Non_Pointer \
- case TC_FIXNUM: \
- case TC_CHARACTER: \
- case_simple_Non_Pointer
-
-#define case_Non_Pointer \
- case TC_PRIMITIVE_EXTERNAL: \
- case_Fasdump_Non_Pointer
-
-/* Missing Non Pointer types (must always be treated specially):
- TC_BROKEN_HEART
- TC_MANIFEST_NM_VECTOR
- TC_MANIFEST_SPECIAL_NM_VECTOR
- TC_REFERENCE_TRAP
-*/
-
-#define case_compiled_entry_point \
- case TC_COMPILED_EXPRESSION: \
- case TC_RETURN_ADDRESS \
-
-#define case_Cell \
- case TC_CELL
-
-/* No missing Cell types */
-\f
-#define case_Fasdump_Pair \
- case TC_LIST: \
- case TC_SCODE_QUOTE: \
- case TC_COMBINATION_1: \
- case TC_EXTENDED_PROCEDURE: \
- case TC_PROCEDURE: \
- case TC_DELAY: \
- case TC_DELAYED: \
- case TC_COMMENT: \
- case TC_LAMBDA: \
- case TC_SEQUENCE_2: \
- case TC_PCOMB1: \
- case TC_ACCESS: \
- case TC_DEFINITION: \
- case TC_ASSIGNMENT: \
- case TC_IN_PACKAGE: \
- case TC_LEXPR: \
- case TC_DISJUNCTION: \
- case TC_COMPILED_PROCEDURE: \
- case TC_COMPILER_LINK: \
- case TC_COMPLEX
-
-#define case_Pair \
- case TC_INTERNED_SYMBOL: \
- case TC_UNINTERNED_SYMBOL: \
- case_Fasdump_Pair
-
-/* Missing pair types (must be treated specially):
- TC_WEAK_CONS
-*/
-
-#define case_Triple \
- case TC_COMBINATION_2: \
- case TC_EXTENDED_LAMBDA: \
- case TC_HUNK3: \
- case TC_CONDITIONAL: \
- case TC_SEQUENCE_3: \
- case TC_PCOMB2
-
-/* Missing triple types (must be treated specially):
- TC_VARIABLE
-*/
-\f
-#define case_Quadruple \
- case TC_QUAD
-
-/* No missing quad types. */
-
-#define case_simple_Vector \
- case TC_NON_MARKED_VECTOR: \
- case TC_VECTOR: \
- case TC_CONTROL_POINT: \
- case TC_COMBINATION: \
- case TC_PCOMB3: \
- case TC_VECTOR_1B: \
- case TC_VECTOR_16B
-
-#define case_Purify_Vector \
- case TC_BIG_FIXNUM: \
- case TC_CHARACTER_STRING: \
- case_simple_Vector
-
-#define case_Vector \
- case TC_ENVIRONMENT: \
- case_Purify_Vector
-
-/* Missing vector types (must be treated specially):
- TC_FUTURE
- TC_BIG_FLONUM
-*/
-\f
-/* Macros for the garbage collector and related programs. */
-
-#define NORMAL_GC 0
-#define PURE_COPY 1
-#define CONSTANT_COPY 2
-
-/* Pointer setup for the GC Type handlers. */
-
-/* Check whether it has been relocated. */
-
-#define Normal_BH(In_GC, then_what) \
-if (Type_Code(*Old) == TC_BROKEN_HEART) \
-{ *Scan = Make_New_Pointer(Type_Code(Temp), *Old); \
- then_what; \
-}
-
-#define Setup_Internal(In_GC, Extra_Code, BH_Code) \
-if And2(In_GC, Consistency_Check) \
- if ((Old >= Highest_Allocated_Address) || (Old < Heap)) \
- { fprintf(stderr, "Out of range pointer: %x.\n", Temp); \
- Microcode_Termination(TERM_EXIT); \
- } \
-if (Old >= Low_Constant) \
- continue; \
-BH_Code; \
-New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
-Extra_Code; \
-continue
-
-#define Setup_Pointer(In_GC, Extra_Code) \
-Setup_Internal(In_GC, Extra_Code, Normal_BH(In_GC, continue))
-
-#define Pointer_End() \
-*Get_Pointer(Temp) = New_Address; \
-*Scan = Make_New_Pointer(Type_Code(Temp), New_Address)
-\f
-/* GC Type handlers. These do the actual work. */
-
-#define Transport_Cell() \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Pair() \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Triple() \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
-
-#define Transport_Quadruple() \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old++; \
-*To++ = *Old; \
-Pointer_End()
-\f
-#ifndef In_Fasdump
-
-/* The Get_Integer below gets the length of the vector.
- Vector_Length(Temp) cannot be used because Temp does
- not necessarily point to the first word of the object.
- Currently only compiled entry points point to the
- "middle" of vectors.
- */
-
-#define Real_Transport_Vector() \
-{ Pointer *Saved_Scan = Scan; \
- Scan = To + 1 + Get_Integer(*Old); \
- if ((Consistency_Check) && \
- (Scan >= Low_Constant) && \
- (To < Low_Constant)) \
- { fprintf(stderr, "\nVector Length %d\n", \
- Get_Integer(*Old)); \
- Microcode_Termination(TERM_EXIT); \
- } \
- while (To != Scan) *To++ = *Old++; \
- Scan = Saved_Scan; \
-}
-
-#else In_Fasdump
-
-#define Real_Transport_Vector() \
-{ Pointer *Saved_Scan = Scan; \
- Scan = To + 1 + Get_Integer(*Old); \
- if (Scan >= Fixes) \
- { Scan = Saved_Scan; \
- NewFree = To; \
- Fixup = Fixes; \
- return false; \
- } \
- while (To != Scan) *To++ = *Old++; \
- Scan = Saved_Scan; \
-}
-
-#endif
-\f
-#ifdef FLOATING_ALIGNMENT
-#define Transport_Flonum() \
- Align_Float(To); \
- New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
- Real_Transport_Vector(); \
- Pointer_End()
-#endif
-
-#define Transport_Vector() \
-Move_Vector: \
- Real_Transport_Vector(); \
- Pointer_End()
-
-#define Transport_Future() \
-if (!(Future_Spliceable(Temp))) \
- goto Move_Vector; \
-*Scan = Future_Value(Temp); \
-Scan -= 1
-\f
-/* Weak Pointer code. The idea here is to support a post-GC pass which
- removes any objects in the CAR of a WEAK_CONS cell which is no longer
- referenced by other objects in the system.
-
- The idea is to maintain a (C based) list of weak conses in old
- space. The head of this list is the variable Weak_Chain. During
- the normal GC pass, weak cons cells are not copied in the normal
- manner. Instead the following structure is built:
-
- Old Space | New Space
- _______________________ | _______________________
- |Broken | New | | | NULL | Old CAR data |
- |Heart | Location ======|==>| | |
- |_______|_____________| | |______|______________|
- |Old Car| Next in | | | Old CDR component |
- | type | chain | | | |
- |_____________________| | |_____________________|
-
-*/
-
-extern Pointer Weak_Chain;
-
-#define Transport_Weak_Cons() \
-{ long Car_Type = Type_Code(*Old); \
- *To++ = Make_New_Pointer(TC_NULL, *Old); \
- Old += 1; \
- *To++ = *Old; \
- *Old = Make_New_Pointer(Car_Type, Weak_Chain); \
- Weak_Chain = Temp; \
- Pointer_End(); \
-}
-\f
-/* Special versions of the above for DumpLoop in Fasdump. This code
- only differs from the code above in that it must check whether
- there is enough space to remember the fixup.
- */
-
-#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
-BH_Code; \
-/* It must be transported to New Space */ \
-New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
-if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
-{ NewFree = To; \
- Fixup = Fixes; \
- return false; \
-} \
-*--Fixes = *Old; \
-*--Fixes = C_To_Scheme(Old); \
-Extra_Code; \
-continue
-
-/* Undefine Symbols */
-
-#define Fasdump_Symbol(global_value) \
-*To++ = *Old; \
-*To++ = global_value; \
-Pointer_End()
-
-#define Fasdump_Variable() \
-*To++ = *Old; \
-*To++ = UNCOMPILED_VARIABLE; \
-*To++ = NIL; \
-Pointer_End()
-\f
-/* Compiled Code Relocation Utilities */
-
-#ifdef CMPGCFILE
-#include CMPGCFILE
-#else
-
-/* Is there anything else that can be done here? */
-
-#define Get_Compiled_Block(address) \
-fprintf(stderr, \
- "\nRelocating compiled code without compiler support!\n"); \
-Microcode_Termination(TERM_COMPILER_DEATH)
-
-#define Compiled_BH(flag, then_what) \
-fprintf(stderr, \
- "\nRelocating compiled code without compiler support!\n"); \
-Microcode_Termination(TERM_COMPILER_DEATH)
-
-#define Transport_Compiled()
-
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gcloop.c,v 9.24 1987/04/03 00:13:50 jinx Rel $
- *
- * This file contains the code for the most primitive part
- * of garbage collection.
- *
- */
-
-#include "scheme.h"
-#include "gccode.h"
-
-/* Exports */
-
-extern Pointer *GCLoop();
-
-#define GC_Pointer(Code) \
-Old = Get_Pointer(Temp); \
-Code
-
-#define Setup_Pointer_for_GC(Extra_Code) \
-GC_Pointer(Setup_Pointer(true, Extra_Code))
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-static Pointer *gc_scan_trap = NULL;
-static Pointer *gc_free_trap = NULL;
-static Pointer gc_trap = Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_MAX_IMMEDIATE);
-#endif
-\f
-Pointer
-*GCLoop(Scan, To_Pointer)
-fast Pointer *Scan;
-Pointer **To_Pointer;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
-
- To = *To_Pointer;
- Low_Constant = Constant_Space;
- for ( ; Scan != To; Scan++)
- { Temp = *Scan;
-
-#ifdef ENABLE_DEBUGGING_TOOLS
- if ((Temp == gc_trap) || (Scan == gc_scan_trap) || (To == gc_free_trap))
- {
- fprintf(stderr, "\nGCLoop: trap.\n");
- }
-#endif
-
- Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
- if (Scan == (Get_Pointer(Temp)))
- { *To_Pointer = To;
- return Scan;
- }
- fprintf(stderr, "GC: Broken heart in scan.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += Get_Integer(Temp);
- break;
-
- case_Non_Pointer:
- break;
-
- case_compiled_entry_point:
- GC_Pointer(Setup_Internal(true,
- Transport_Compiled(),
- Compiled_BH(true, continue)));
-
- case_Cell:
- Setup_Pointer_for_GC(Transport_Cell());
-
- case TC_REFERENCE_TRAP:
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
- break;
- }
- /* It is a pair, fall through. */
- case_Pair:
- Setup_Pointer_for_GC(Transport_Pair());
-
- case TC_VARIABLE:
- case_Triple:
- Setup_Pointer_for_GC(Transport_Triple());
-
-/* GCLoop continues on the next page */
-\f
-/* GCLoop, continued */
-
- case_Quadruple:
- Setup_Pointer_for_GC(Transport_Quadruple());
-
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- Setup_Pointer_for_GC(Transport_Flonum());
-#else
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
- case_Vector:
- Setup_Pointer_for_GC(Transport_Vector());
-
- case TC_FUTURE:
- Setup_Pointer_for_GC(Transport_Future());
-
- case TC_WEAK_CONS:
- Setup_Pointer_for_GC(Transport_Weak_Cons());
-
- default:
- fprintf(stderr,
- "GCLoop: Bad type code = 0x%02x\n",
- Type_Code(Temp));
- Invalid_Type_Code();
-
- } /* Switch_by_GC_Type */
- } /* For loop */
- *To_Pointer = To;
- return To;
-} /* GCLoop */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $
- *
- * This file contains the table which maps between Types and
- * GC Types.
- *
- */
-\f
- /*********************************/
- /* Mapping GC_Type to Type_Codes */
- /*********************************/
-
-int GC_Type_Map[MAX_SAFE_TYPE + 1] = {
- GC_Non_Pointer, /* TC_NULL,etc */
- GC_Pair, /* TC_LIST */
- GC_Non_Pointer, /* TC_CHARACTER */
- GC_Pair, /* TC_SCODE_QUOTE */
- GC_Triple, /* TC_PCOMB2 */
- GC_Pair, /* TC_UNINTERNED_SYMBOL */
- GC_Vector, /* TC_BIG_FLONUM */
- GC_Pair, /* TC_COMBINATION_1 */
- GC_Non_Pointer, /* TC_TRUE */
- GC_Pair, /* TC_EXTENDED_PROCEDURE */
- GC_Vector, /* TC_VECTOR */
- GC_Non_Pointer, /* TC_RETURN_CODE */
- GC_Triple, /* TC_COMBINATION_2 */
- GC_Pair, /* TC_COMPILED_PROCEDURE */
- GC_Vector, /* TC_BIG_FIXNUM */
- GC_Pair, /* TC_PROCEDURE */
- GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
- GC_Pair, /* TC_DELAY */
- GC_Vector, /* TC_ENVIRONMENT */
- GC_Pair, /* TC_DELAYED */
- GC_Triple, /* TC_EXTENDED_LAMBDA */
- GC_Pair, /* TC_COMMENT */
- GC_Vector, /* TC_NON_MARKED_VECTOR */
- GC_Pair, /* TC_LAMBDA */
- GC_Non_Pointer, /* TC_PRIMITIVE */
- GC_Pair, /* TC_SEQUENCE_2 */
- GC_Non_Pointer, /* TC_FIXNUM */
- GC_Pair, /* TC_PCOMB1 */
- GC_Vector, /* TC_CONTROL_POINT */
- GC_Pair, /* TC_INTERNED_SYMBOL */
- GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
- GC_Pair, /* TC_ACCESS */
- GC_Undefined, /* 0x20 */
- GC_Pair, /* TC_DEFINITION */
- GC_Special, /* TC_BROKEN_HEART */
- GC_Pair, /* TC_ASSIGNMENT */
- GC_Triple, /* TC_HUNK3 */
- GC_Pair, /* TC_IN_PACKAGE */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Vector, /* TC_COMBINATION */
- GC_Special, /* TC_MANIFEST_NM_VECTOR */
- GC_Compiled, /* TC_COMPILED_EXPRESSION */
- GC_Pair, /* TC_LEXPR */
- GC_Vector, /* TC_PCOMB3 */
- GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
- GC_Triple, /* TC_VARIABLE */
- GC_Non_Pointer, /* TC_THE_ENVIRONMENT */
- GC_Vector, /* TC_FUTURE */
- GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
- GC_Non_Pointer, /* TC_PCOMB0 */
- GC_Vector, /* TC_VECTOR_16B */
- GC_Special, /* TC_REFERENCE_TRAP */
- GC_Triple, /* TC_SEQUENCE_3 */
- GC_Triple, /* TC_CONDITIONAL */
- GC_Pair, /* TC_DISJUNCTION */
- GC_Cell, /* TC_CELL */
- GC_Pair, /* TC_WEAK_CONS */
- GC_Quadruple, /* TC_QUAD */
- GC_Compiled, /* TC_RETURN_ADDRESS */
- GC_Pair, /* TC_COMPILER_LINK */
- GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
- GC_Pair, /* TC_COMPLEX */
- GC_Undefined, /* 0x3D */
- GC_Undefined, /* 0x3E */
- GC_Undefined, /* 0x3F */
- GC_Undefined, /* 0x40 */
- GC_Undefined, /* 0x41 */
- GC_Undefined, /* 0x42 */
- GC_Undefined, /* 0x43 */
- GC_Undefined, /* 0x44 */
- GC_Undefined, /* 0x45 */
- GC_Undefined, /* 0x46 */
- GC_Undefined, /* 0x47 */
- GC_Undefined, /* 0x48 */
- GC_Undefined, /* 0x49 */
- GC_Undefined, /* 0x4A */
- GC_Undefined, /* 0x4B */
- GC_Undefined, /* 0x4C */
- GC_Undefined, /* 0x4D */
- GC_Undefined, /* 0x4E */
- GC_Undefined, /* 0x4F */
- GC_Undefined, /* 0x50 */
- GC_Undefined, /* 0x51 */
- GC_Undefined, /* 0x52 */
- GC_Undefined, /* 0x53 */
- GC_Undefined, /* 0x54 */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Undefined, /* 0x55 */
- GC_Undefined, /* 0x56 */
- GC_Undefined, /* 0x57 */
- GC_Undefined, /* 0x58 */
- GC_Undefined, /* 0x59 */
- GC_Undefined, /* 0x5A */
- GC_Undefined, /* 0x5B */
- GC_Undefined, /* 0x5C */
- GC_Undefined, /* 0x5D */
- GC_Undefined, /* 0x5E */
- GC_Undefined, /* 0x5F */
- GC_Undefined, /* 0x60 */
- GC_Undefined, /* 0x61 */
- GC_Undefined, /* 0x62 */
- GC_Undefined, /* 0x63 */
- GC_Undefined, /* 0x64 */
- GC_Undefined, /* 0x65 */
- GC_Undefined, /* 0x66 */
- GC_Undefined, /* 0x67 */
- GC_Undefined, /* 0x68 */
- GC_Undefined, /* 0x69 */
- GC_Undefined, /* 0x6A */
- GC_Undefined, /* 0x6B */
- GC_Undefined, /* 0x6C */
- GC_Undefined, /* 0x6D */
- GC_Undefined, /* 0x6E */
- GC_Undefined, /* 0x6F */
- GC_Undefined, /* 0x70 */
- GC_Undefined, /* 0x71 */
- GC_Undefined, /* 0x72 */
- GC_Undefined, /* 0x73 */
- GC_Undefined, /* 0x74 */
- GC_Undefined, /* 0x75 */
- GC_Undefined, /* 0x76 */
- GC_Undefined, /* 0x77 */
- GC_Undefined, /* 0x78 */
- GC_Undefined, /* 0x79 */
- GC_Undefined, /* 0x7A */
- GC_Undefined, /* 0x7B */
- GC_Undefined, /* 0x7C */
- GC_Undefined, /* 0x7D */
- GC_Undefined, /* 0x7E */
- GC_Undefined /* 0x7F */
- };
-
-#if (MAX_SAFE_TYPE != 0x7F)
-#include "gctype.c and scheme.h inconsistent -- GC_Type_Map"
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.22 1987/04/16 02:23:19 jinx Rel $ */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "bignum.h"
-#include "flonum.h"
-#include "zones.h"
-\f
-Built_In_Primitive(Prim_Zero, 1, "ZERO?", 0xE6)
-{
- Primitive_1_Arg();
-
- Set_Time_Zone(Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM: if (Get_Integer(Arg1) == 0) return TRUTH;
- else return NIL;
- case TC_BIG_FLONUM: if (Get_Float(Arg1) == 0.0) return TRUTH;
- else return NIL;
- case TC_BIG_FIXNUM: if (ZERO_BIGNUM(Fetch_Bignum(Arg1))) return TRUTH;
- else return NIL;
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
- /*NOTREACHED*/
-}
-
-Pointer
-C_Integer_To_Scheme_Integer(C)
- long C;
-{
- fast bigdigit *Answer, *SCAN, *size;
- long Length;
-
- if (Fixnum_Fits(C))
- return Make_Non_Pointer(TC_FIXNUM, C);
- Length = Align(C_INTEGER_LENGTH_AS_BIGNUM);
- Primitive_GC_If_Needed(Length);
- Answer = BIGNUM(Free);
- Prepare_Header(Answer, 0, (C >= 0) ? POSITIVE : NEGATIVE);
- size = &LEN(Answer);
- if (C < 0)
- C = - C;
- for (SCAN = Bignum_Bottom(Answer); C != 0; *size += 1)
- {
- *SCAN++ = Rem_Radix(C);
- C = Div_Radix(C);
- }
- *((Pointer *) Answer) = Make_Header(Align(*size));
- Free += Length;
- Debug_Test(Free-Length);
- return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
-}
-\f
-int
-Scheme_Integer_To_C_Integer(Arg1, C)
- Pointer Arg1;
- long *C;
-{
- int type = Type_Code(Arg1);
- fast bigdigit *SCAN, *ARG1;
- fast long Answer, i;
- long Length;
-
- if (type == TC_FIXNUM)
- {
- Sign_Extend(Arg1, *C);
- return PRIM_DONE;
- }
- if (type != TC_BIG_FIXNUM)
- return ERR_ARG_1_WRONG_TYPE;
- ARG1 = BIGNUM(Get_Pointer(Arg1));
- Length = LEN(ARG1);
- if (Length == 0)
- Answer = 0;
- else if (Length > C_INTEGER_LENGTH_AS_BIGNUM)
- return ERR_ARG_1_BAD_RANGE;
- else if (Length < C_INTEGER_LENGTH_AS_BIGNUM)
- for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
- Answer = Mul_Radix(Answer) + *SCAN--;
- else
- /* Length == C_INTEGER_LENGTH_AS_BIGNUM */
- for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
- /* Attempting to take care of overflow problems */
- { Answer = Mul_Radix(Answer);
- if (Answer < 0)
- return ERR_ARG_1_BAD_RANGE;
- Answer = Answer + *SCAN--;
- if (Answer < 0)
- return ERR_ARG_1_BAD_RANGE;
- }
- if NEG_BIGNUM(ARG1)
- Answer = - Answer;
- *C = Answer;
- return PRIM_DONE;
-}
-
-Pointer
-Fetch_Bignum_One()
-{
- return Get_Fixed_Obj_Slot(Bignum_One);
-}
-\f
-#define Sign_Check(Normal_Op, Big_Op) \
- Primitive_1_Arg(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM: { long Value; \
- Sign_Extend(Arg1, Value); \
- if (Value Normal_Op 0) return TRUTH; \
- else return NIL; \
- } \
- case TC_BIG_FLONUM: if (Get_Float(Arg1) Normal_Op 0.0) return TRUTH;\
- else return NIL; \
-P2_Sign_Check(Big_Op)
-
-#define P2_Sign_Check(Big_Op) \
- case TC_BIG_FIXNUM: if ((LEN(Fetch_Bignum(Arg1)) != 0) \
- && Big_Op(Fetch_Bignum(Arg1))) \
- return TRUTH; \
- else return NIL; \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-
-Built_In_Primitive(Prim_Positive, 1, "POSITIVE?", 0xE7)
-{
- Sign_Check(>, POS_BIGNUM);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Negative, 1, "NEGATIVE?", 0xE8)
-{
- Sign_Check(<, NEG_BIGNUM);
- /*NOTREACHED*/
-}
-\f
-#define Inc_Dec(Normal_Op, Big_Op) \
- Primitive_1_Arg(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM: \
- { fast long A, Result; \
- Sign_Extend(Arg1, A); \
- Result = A Normal_Op 1; \
- if (Fixnum_Fits(Result)) \
- return Make_Non_Pointer(TC_FIXNUM, Result); \
-P2_Inc_Dec(Normal_Op, Big_Op)
-
-#define P2_Inc_Dec(Normal_Op, Big_Op) \
- { Pointer Ans = Fix_To_Big(Arg1); \
- Bignum_Operation(Big_Op(Fetch_Bignum(Ans), \
- Fetch_Bignum(Fetch_Bignum_One())), \
- Ans); \
- return Ans; \
- } \
- } \
-P3_Inc_Dec(Normal_Op, Big_Op)
-
-#define P3_Inc_Dec(Normal_Op, Big_Op) \
- case TC_BIG_FLONUM: \
- Reduced_Flonum_Result(Get_Float(Arg1) Normal_Op 1); \
- case TC_BIG_FIXNUM: \
- { Pointer Ans; \
- Bignum_Operation(Big_Op(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Fetch_Bignum_One())), \
- Ans); \
- return Ans; \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-Built_In_Primitive(Prim_One_Plus, 1, "1+", 0xF1)
-{
- Inc_Dec(+, plus_signed_bignum);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_M_1_Plus, 1, "-1+", 0xF2)
-{
- Inc_Dec(-, minus_signed_bignum);
- /*NOTREACHED*/
-}
-\f
-#define Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- Primitive_2_Args(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { long A, B; \
- Sign_Extend(Arg1, A); \
- Sign_Extend(Arg2, B); \
- return (A GENERAL_OP B) ? TRUTH : NIL; \
- } \
-P2_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-
-#define P2_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { long A; \
- Sign_Extend(Arg1, A); \
- return (A GENERAL_OP (Get_Float(Arg2))) ? TRUTH : NIL; \
- } \
- case TC_BIG_FIXNUM: \
- { Pointer Ans = Fix_To_Big(Arg1); \
- return (big_compare(Fetch_Bignum(Ans), \
- Fetch_Bignum(Arg2)) == BIG_OP) ? \
- TRUTH : NIL; \
- } \
-P3_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-\f
-#define P3_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- case TC_BIG_FLONUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { long B; \
- Sign_Extend(Arg2, B); \
- return (Get_Float(Arg1) GENERAL_OP B) ? TRUTH : NIL; \
- } \
-P4_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-
-#define P4_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- return (Get_Float(Arg1) GENERAL_OP Get_Float(Arg2)) ? \
- TRUTH : NIL; \
- case TC_BIG_FIXNUM: \
- { Pointer A; \
- A = Big_To_Float(Arg2); \
- if (Type_Code(A) == TC_BIG_FLONUM) \
- return (Get_Float(Arg1) GENERAL_OP Get_Float(A)) ? \
- TRUTH : NIL; \
-P5_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-\f
-#define P5_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- case TC_BIG_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { Pointer Ans = Fix_To_Big(Arg2); \
- return (big_compare(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Ans)) == BIG_OP) ? \
- TRUTH : NIL; \
- } \
-P6_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-
-#define P6_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { Pointer A = Big_To_Float(Arg1); \
- if (Type_Code(A) == TC_BIG_FLONUM) \
- return (Get_Float(A) GENERAL_OP Get_Float(Arg2)) ? \
- TRUTH : NIL; \
- Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
- } \
-P7_Two_Op_Comparator(GENERAL_OP, BIG_OP)
-\f
-#define P7_Two_Op_Comparator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- return (big_compare(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Arg2)) == BIG_OP) ? \
- TRUTH : NIL; \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-Built_In_Primitive(Prim_Equal_Number, 2, "&=", 0xE9)
-{
- Two_Op_Comparator(==, EQUAL);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Less, 2, "&<", 0xEA)
-{
- Two_Op_Comparator(<, TWO_BIGGER);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Greater, 2, "&>", 0xEB)
-{
- Two_Op_Comparator(>, ONE_BIGGER);
- /*NOTREACHED*/
-}
-\f
-#define Two_Op_Operator(GENERAL_OP, BIG_OP) \
- Primitive_2_Args(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { fast long A, B, Result; \
- Sign_Extend(Arg1, A); \
- Sign_Extend(Arg2, B); \
- Result = (A GENERAL_OP B); \
- if (Fixnum_Fits(Result)) \
- return Make_Non_Pointer(TC_FIXNUM, Result); \
-P2_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P2_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- { Pointer Big_Arg1, Big_Arg2, Big_Result; \
- Big_Arg1 = Fix_To_Big(Arg1); \
- Big_Arg2 = Fix_To_Big(Arg2); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
- Fetch_Bignum(Big_Arg2)), \
- Big_Result); \
- return Big_Result; \
- } \
- } \
-P3_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P3_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { fast long A; \
- Sign_Extend(Arg1, A); \
- Reduced_Flonum_Result(A GENERAL_OP Get_Float(Arg2)); \
- } \
-P4_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P4_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer Big_Arg1 = Fix_To_Big(Arg1); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Big_Arg1), \
- Fetch_Bignum(Arg2)), \
- Big_Arg1); \
- return Big_Arg1; \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
-P5_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P5_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { fast long B; \
- Sign_Extend(Arg2, B); \
- Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP B); \
- } \
- case TC_BIG_FLONUM: \
- Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
- Get_Float(Arg2)); \
-P6_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P6_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer B = Big_To_Float(Arg2); \
- if (Type_Code(B) == TC_BIG_FLONUM) \
- { Reduced_Flonum_Result(Get_Float(Arg1) GENERAL_OP \
- Get_Float(B)); \
- } \
- Primitive_Error(ERR_ARG_2_FAILED_COERCION); \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
-P7_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P7_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { switch (Type_Code(Arg2)) \
- { case TC_FIXNUM: \
- { Pointer Big_Arg2 = Fix_To_Big(Arg2); \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Big_Arg2)), \
- Big_Arg2); \
- return Big_Arg2; \
- } \
-P8_Two_Op_Operator(GENERAL_OP, BIG_OP)
-
-#define P8_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FLONUM: \
- { Pointer A = Big_To_Float(Arg1); \
- if (Type_Code(A) == TC_BIG_FLONUM) \
- { Reduced_Flonum_Result(Get_Float(A) GENERAL_OP \
- Get_Float(Arg2)); \
- } \
- Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
- } \
-P9_Two_Op_Operator(GENERAL_OP, BIG_OP)
-\f
-#define P9_Two_Op_Operator(GENERAL_OP, BIG_OP) \
- case TC_BIG_FIXNUM: \
- { Pointer Ans; \
- Bignum_Operation(BIG_OP(Fetch_Bignum(Arg1), \
- Fetch_Bignum(Arg2)), \
- Ans); \
- return Ans; \
- } \
- default: \
- Primitive_Error(ERR_ARG_2_WRONG_TYPE); \
- } \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-Built_In_Primitive(Prim_Plus, 2, "&+", 0xEC)
-{
- Two_Op_Operator(+, plus_signed_bignum);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Minus, 2, "&-", 0xED)
-{
- Two_Op_Operator(-, minus_signed_bignum);
- /*NOTREACHED*/
-}
-\f
-Built_In_Primitive(Prim_Multiply, 2, "&*", 0xEE)
-{
- /* Mul is machine dependent and lives in os.c */
- extern Pointer Mul();
- Primitive_2_Args();
-
- Set_Time_Zone(Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast Pointer Result;
- Result = Mul(Arg1, Arg2);
- if (Result != NIL) return Result;
- { Pointer Big_Arg1, Big_Arg2;
- Big_Arg1 = Fix_To_Big(Arg1);
- Big_Arg2 = Fix_To_Big(Arg2);
- Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1),
- Fetch_Bignum(Big_Arg2)),
- Big_Arg1);
- return Big_Arg1;
- }
- }
- case TC_BIG_FLONUM:
- { fast long A;
- Sign_Extend(Arg1, A);
- Reduced_Flonum_Result(A * Get_Float(Arg2));
- }
-
-/* Prim_Multiply continues on the next page */
-\f
-/* Prim_Multiply, continued */
-
- case TC_BIG_FIXNUM:
- { Pointer Big_Arg1 = Fix_To_Big(Arg1);
- Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Big_Arg1),
- Fetch_Bignum(Arg2)),
- Big_Arg1);
- return Big_Arg1;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- case TC_BIG_FLONUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long B;
- Sign_Extend(Arg2, B);
- Reduced_Flonum_Result(Get_Float(Arg1) * B);
- }
- case TC_BIG_FLONUM:
- Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2));
- case TC_BIG_FIXNUM:
- { Pointer B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(B));
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
-
-/* Prim_Multiply continues on the next page */
-\f
-/* Prim_Multiply, continued */
-
- case TC_BIG_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { Pointer Big_Arg2 = Fix_To_Big(Arg2);
- Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Big_Arg2)),
- Big_Arg2);
- return Big_Arg2;
- }
- case TC_BIG_FLONUM:
- { Pointer A = Big_To_Float(Arg1);
- if (Type_Code(A) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(A) * Get_Float(Arg2));
- }
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- }
- /*NOTREACHED*/
- case TC_BIG_FIXNUM:
- { Pointer Ans;
- Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Arg2)),
- Ans);
- return Ans;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
- /*NOTREACHED*/
-}
-\f
-Built_In_Primitive(Prim_Divide, 2, "&/", 0xEF)
-{
- Primitive_2_Args();
-
- Set_Time_Zone(Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long A, B;
- double Result;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
- if (B==0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Result = (double) A / (double) B;
- Reduced_Flonum_Result(Result);
- }
- case TC_BIG_FLONUM:
- { fast long A;
- Sign_Extend(Arg1, A);
- if (Get_Float(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Reduced_Flonum_Result(((double) A) / Get_Float(Arg2));
- }
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { Pointer Big_Arg1, Result, B;
- long A;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Big_Arg1 = Fix_To_Big(Arg1);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
- Fetch_Bignum(Arg2)),
- Result);
- if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
- return (Vector_Ref(Result, CONS_CAR));
- Sign_Extend(Arg1, A);
- { B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(A / Get_Float(B));
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- case TC_BIG_FLONUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long B;
- Sign_Extend(Arg2, B);
- if (B == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- { Reduced_Flonum_Result(Get_Float(Arg1) / ((double) B));
- }
- }
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FLONUM:
- if (Get_Float(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
- case TC_BIG_FIXNUM:
- { Pointer B;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(B));
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { Pointer Big_Arg2, Result, A;
- Big_Arg2 = Fix_To_Big(Arg2);
- if (ZERO_BIGNUM(Fetch_Bignum(Big_Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Big_Arg2)),
- Result);
- if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
- return (Vector_Ref(Result, CONS_CAR));
- A = Big_To_Float(Arg1);
- if (Type_Code(A) == TC_BIG_FLONUM)
- { long B;
- Sign_Extend(Arg2, B);
- Reduced_Flonum_Result(Get_Float(A) / ((double) B));
- }
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- }
- /*NOTREACHED*/
- case TC_BIG_FLONUM:
- { Pointer A;
- if (Get_Float(Arg2) == 0.0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- A = Big_To_Float(Arg1);
- if (Type_Code(A) == TC_BIG_FLONUM)
- { Reduced_Flonum_Result(Get_Float(A) / Get_Float(Arg2));
- }
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- }
- /*NOTREACHED*/
-
-/* Prim_Divide continues on the next page */
-\f
-/* Prim_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { Pointer Result, A, B;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Arg2)),
- Result);
- if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
- return (Vector_Ref(Result, CONS_CAR));
- A = Big_To_Float(Arg1);
- if (Type_Code(A) == TC_BIG_FLONUM)
- { B = Big_To_Float(Arg2);
- if (Type_Code(B) == TC_BIG_FLONUM)
- { if (Get_Float(B) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- { Reduced_Flonum_Result(Get_Float(A) / Get_Float(B));
- }
- }
- Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- }
- /*NOTREACHED*/
- Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
- /*NOTREACHED*/
-}
-\f
-Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE", 0xF0)
-{
- Primitive_2_Args();
-
- Set_Time_Zone(Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { fast long A, B, C, D;
- Pointer *Cons_Cell;
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
- if (B == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Primitive_GC_If_Needed(2);
- /* These (C & D) are necessary because Make_Non_Pointer casts to
- Pointer which is unsigned long, and then the arithmetic is wrong
- if the operations are placed in the macro "call". */
- C = A / B;
- D = A % B;
- Cons_Cell = Free;
- Free += 2;
- Cons_Cell[CONS_CAR] = Make_Non_Pointer(TC_FIXNUM, C);
- Cons_Cell[CONS_CDR] = Make_Non_Pointer(TC_FIXNUM, D);
- return Make_Pointer(TC_LIST, Cons_Cell);
- }
- case TC_BIG_FIXNUM:
- { Pointer Big_Arg1, Pair;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Big_Arg1 = Fix_To_Big(Arg1);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
- Fetch_Bignum(Arg2)),
- Pair);
- return Pair;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
-
-/* Prim_Integer_Divide continues on the next page */
-\f
-/* Prim_Integer_Divide, continued */
-
- case TC_BIG_FIXNUM:
- { switch (Type_Code(Arg2))
- { case TC_FIXNUM:
- { Pointer Big_Arg2, Pair;
- if (Get_Integer(Arg2) == 0)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Big_Arg2 = Fix_To_Big(Arg2);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Big_Arg2)),
- Pair);
- return Pair;
- }
- case TC_BIG_FIXNUM:
- { Pointer Pair;
- if (ZERO_BIGNUM(Fetch_Bignum(Arg2)))
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
- Fetch_Bignum(Arg2)),
- Pair);
- return Pair;
- }
- default:
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- }
- /*NOTREACHED*/
- }
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- }
- /*NOTREACHED*/
-}
-\f
-/* Generic sqrt and transcendental functions are created by generalizing
- their floating point counterparts.
-*/
-
-#define Generic_Function(Routine) \
- double Routine(); \
- Primitive_1_Arg(); \
- \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM: \
- { long Arg; \
- Sign_Extend(Arg1, Arg); \
- Reduced_Flonum_Result(Routine((double) Arg)); \
- } \
- case TC_BIG_FLONUM: \
- Reduced_Flonum_Result(Routine(Get_Float(Arg1))); \
- case TC_BIG_FIXNUM: \
- { Pointer A = Big_To_Float(Arg1); \
- if (Type_Code(A) != TC_BIG_FLONUM) \
- Primitive_Error(ERR_ARG_1_FAILED_COERCION); \
- Reduced_Flonum_Result(Routine(Get_Float(A))); \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-/* This horrible hack because there are no lambda-expressions in C. */
-
-#define Generic_Restriction(Lambda, Routine, Restriction) \
-double \
-Lambda(arg) \
- fast double arg; \
-{ \
- double Routine(); \
- \
- if (arg Restriction 0.0) \
- Primitive_Error(ERR_ARG_1_BAD_RANGE); \
- return Routine(arg); \
-}
-\f
-/* And here the functions themselves */
-
-Generic_Restriction(Scheme_Sqrt, sqrt, <)
-Generic_Restriction(Scheme_Ln, log, <=)
-
-Built_In_Primitive(Prim_Sqrt, 1, "SQRT", 0xF7)
-{
- Generic_Function(Scheme_Sqrt);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Exp, 1, "EXP", 0xF8)
-{
- Generic_Function(exp);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Ln, 1, "LOG", 0xF9)
-{
- Generic_Function(Scheme_Ln);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Sine, 1, "SIN", 0xFA)
-{
- Generic_Function(sin);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Cosine, 1, "COS", 0xFB)
-{
- Generic_Function(cos);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Arctan, 1, "&ATAN", 0xFC)
-{
- Generic_Function(atan);
- /*NOTREACHED*/
-}
-\f
-/* Coercions from Floating point to integers.
-
- There are four possible ways to coerce:
-
- - Truncate : towards 0.
- - Round : towards closest integer.
- - Floor : towards -infinity.
- - Ceiling : towards +infinity.
-
- All these primitives differ only in how floating point numbers
- are mapped before they are truncated.
-
- If the system does not provide the double precision procedures
- floor and ceil, Floor is incorrect for negative integers in
- floating point format, and Ceiling is incorrect for positive
- integers in floating point format.
-*/
-
-#define Truncate_Mapping(arg) arg
-#define Round_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 0.5) : ((arg) - 0.5))
-
-#ifdef HAS_FLOOR
-
-extern double floor(), ceil();
-#define Floor_Mapping(arg) floor(arg)
-#define Ceiling_Mapping(arg) ceil(arg)
-
-#else
-
-#define Floor_Mapping(arg) ((arg) >= 0.0 ? (arg) : ((arg) - 1.0))
-#define Ceiling_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 1.0) : (arg))
-
-#endif
-\f
-#define Flonum_To_Integer(How_To_Do_It) \
- Primitive_1_Arg(); \
- Set_Time_Zone(Zone_Math); \
- switch (Type_Code(Arg1)) \
- { case TC_FIXNUM : \
- case TC_BIG_FIXNUM: return Arg1; \
- case TC_BIG_FLONUM: \
- { fast double Arg = Get_Float(Arg1); \
- fast double temp = How_To_Do_It(Arg); \
- Pointer Result; \
- if (flonum_exceeds_fixnum(temp)) Result = Float_To_Big(temp); \
- else double_into_fixnum(temp, Result); \
- return Result; \
- } \
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
- }
-
-Built_In_Primitive(Prim_Truncate, 1, "TRUNCATE", 0xF3)
-{
- Flonum_To_Integer(Truncate_Mapping);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Round, 1, "ROUND", 0xF4)
-{
- Flonum_To_Integer(Round_Mapping);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Floor, 1, "FLOOR", 0xF5)
-{
- Flonum_To_Integer(Floor_Mapping);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Ceiling, 1, "CEILING", 0xF6)
-{
- Flonum_To_Integer(Ceiling_Mapping);
- /*NOTREACHED*/
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.22 1987/04/16 02:23:38 jinx Rel $
- *
- * History maintenance data structures and support.
- *
- */
-
-/*
- * The history consists of a "vertebra" which is a doubly linked ring,
- * each entry pointing to a "rib". The rib consists of a singly
- * linked ring whose entries contain expressions and environments.
- */
-
-#define HIST_RIB 0
-#define HIST_NEXT_SUBPROBLEM 1
-#define HIST_PREV_SUBPROBLEM 2
-#define HIST_MARK 1
-
-#define RIB_EXP 0
-#define RIB_ENV 1
-#define RIB_NEXT_REDUCTION 2
-#define RIB_MARK 2
-
-/* Save_History places a restore history frame on the stack. Such a
- * frame consists of a normal continuation frame plus a pointer to the
- * stacklet on which the last restore history is located and the
- * offset within that stacklet. If the last restore history is in
- * this stacklet then the history pointer is NIL to signify this. If
- * there is no previous restore history then the history pointer is
- * NIL and the offset is 0.
- */
-
-#define Save_History(Return_Code) \
-{ \
- if (Prev_Restore_History_Stacklet == NULL) \
- Push(NIL); \
- else \
- Push(Make_Pointer(TC_CONTROL_POINT, \
- Prev_Restore_History_Stacklet)); \
- Push(Make_Non_Pointer(TC_FIXNUM, Prev_Restore_History_Offset)); \
- Store_Expression(Make_Pointer(TC_HUNK3, History)); \
- Store_Return((Return_Code)); \
- Save_Cont(); \
- History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); \
-}
-\f
-/* History manipulation in the interpreter. */
-
-#ifdef COMPILE_HISTORY
-#define New_Subproblem(Expr, Env) \
-{ fast Pointer *Rib; \
- History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \
- History[HIST_MARK] |= DANGER_BIT; \
- Rib = Get_Pointer(History[HIST_RIB]); \
- Rib[RIB_MARK] |= DANGER_BIT; \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
-}
-
-#define Reuse_Subproblem(Expr, Env) \
-{ fast Pointer *Rib; \
- Rib = Get_Pointer(History[HIST_RIB]); \
- Rib[RIB_MARK] |= DANGER_BIT; \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
-}
-
-#define New_Reduction(Expr, Env) \
-{ fast Pointer *Rib; \
- Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \
- RIB_NEXT_REDUCTION)); \
- History[HIST_RIB] = Make_Pointer(TC_HUNK3, Rib); \
- Rib[RIB_ENV] = Env; \
- Rib[RIB_EXP] = Expr; \
- Rib[RIB_MARK] &= ~DANGER_BIT; \
-}
-
-#define End_Subproblem() \
- History[HIST_MARK] &= ~DANGER_BIT; \
- History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]);
-
-#else /* COMPILE_HISTORY */
-#define New_Subproblem(Expr, Env) { }
-#define Reuse_Subproblem(Expr, Env) { }
-#define New_Reduction(Expr, Env) { }
-#define End_Subproblem() { }
-#endif /* COMPILE_HISTORY */
-\f
-/* History manipulation for the compiled code interface. */
-
-#ifdef COMPILE_HISTORY
-
-#define Compiler_New_Reduction() \
-{ New_Reduction(NIL, \
- Make_Non_Pointer(TC_RETURN_CODE, \
- RC_POP_FROM_COMPILED_CODE)); \
-}
-
-#define Compiler_New_Subproblem() \
-{ New_Subproblem(NIL, \
- Make_Non_Pointer(TC_RETURN_CODE, \
- RC_POP_FROM_COMPILED_CODE)); \
-}
-
-#define Compiler_End_Subproblem() \
-{ End_Subproblem(); \
-}
-
-#else /* COMPILE_HISTORY */
-
-#define Compiler_New_Reduction()
-#define Compiler_New_Subproblem()
-#define Compiler_End_Subproblem()
-
-#endif /* COMPILE_HISTORY */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.23 1987/04/16 02:23:49 jinx Exp $
- *
- * This file contains various hooks and handles which connect the
- * primitives with the main interpreter.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "winder.h"
-\f
-/* (APPLY FN LIST-OF-ARGUMENTS)
- Calls the function FN to the arguments specified in the list
- LIST-OF-ARGUMENTS. FN must be a primitive procedure, compound
- procedure, or control point. */
-
-Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5)
-{
- fast Pointer scan_list, *scan_stack;
- fast long number_of_args, i;
-#ifdef butterfly
- Pointer *saved_stack_pointer;
-#endif
- Primitive_2_Args();
-
- /* Since this primitive must pop its own frame off and push a new
- frame on the stack, it has to be careful. Its own stack frame is
- needed if an error or GC is required. So these checks are done
- first (at the cost of traversing the argument list twice), then
- the primitive's frame is popped, and finally the new frame is
- constructed.
-
- Originally this code tried to be clever by copying the argument
- list into a linear (vector-like) form, so as to avoid the
- overhead of traversing the list twice. Unfortunately, the
- overhead of maintaining this other form (e.g. PRIMITIVE_GC_If_Needed)
- is sufficiently high that it probably makes up for the time saved. */
-
- Touch_In_Primitive( Arg2, scan_list);
- number_of_args = 0;
- while (Type_Code( scan_list) == TC_LIST)
- {
- number_of_args += 1;
- Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
- }
- if (scan_list != NIL)
- Primitive_Error( ERR_ARG_2_WRONG_TYPE);
-#ifdef USE_STACKLETS
- /* This is conservative: if the number of arguments is large enough
- the Will_Push below may try to allocate space on the heap for the
- stack frame. */
- Primitive_GC_If_Needed(New_Stacklet_Size(number_of_args +
- STACK_ENV_EXTRA_SLOTS + 1));
-#endif
- Pop_Primitive_Frame( 2);
-\f
- Will_Push( (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
-#ifdef butterfly
- saved_stack_pointer = Stack_Pointer;
-#endif
- scan_stack = Simulate_Pushing( number_of_args);
- Stack_Pointer = scan_stack;
- i = number_of_args;
- Touch_In_Primitive( Arg2, scan_list);
- while (i > 0)
- {
-#ifdef butterfly
- /* Check for abominable case of someone bashing the arg list. */
- if (Type_Code( scan_list) != TC_LIST)
- {
- Stack_Pointer = saved_stack_pointer;
- Primitive_Error( ERR_ARG_2_BAD_RANGE);
- }
-#endif
- *scan_stack++ = Vector_Ref( scan_list, CONS_CAR);
- Touch_In_Primitive( Vector_Ref( scan_list, CONS_CDR), scan_list);
- i -= 1;
- }
- Push( Arg1); /* The procedure */
- Push( (STACK_FRAME_HEADER + number_of_args));
- Pushed();
- longjmp( *Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* This code used to be in the middle of Make_Control_Point, replaced
- * by CWCC below. Preprocessor conditionals do not work in macros.
- */
-
-#define CWCC(Return_Code) \
- fast Pointer *From_Where; \
- Primitive_1_Arg(); \
- CWCC_1(); \
- /* Implementation detail: in addition to setting aside the old \
- stacklet on a catch, the new stacklet is cleared and a return \
- code is placed at the base of the (now clear) stack indicating \
- that a return back through here requires restoring the stacklet. \
- The current enabled interrupts are also saved in the old stacklet. \
- \
- >>> Temporarily (maybe) the act of doing a CATCH will disable any \
- >>> return hook that may be in the stack. \
- \
- >>> Don't even think about adding COMPILER to this stuff! \
- */ \
- Pop_Primitive_Frame(1); \
- if (Return_Hook_Address != NULL) \
- { *Return_Hook_Address = Old_Return_Code; \
- Return_Hook_Address = NULL; \
- } \
-/* Put down frames to restore history and interrupts so that these \
- * operations will be performed on a throw. \
- */ \
- Will_Push(CONTINUATION_SIZE + HISTORY_SIZE); \
- Save_History(Return_Code); \
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, IntEnb)); \
- Store_Return(RC_RESTORE_INT_MASK); \
- Save_Cont(); \
- Pushed(); \
-/* There is no history to use since the last control point was formed. \
- */ \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
- CWCC_2(); \
-/* Will_Push(3); -- we just cleared the stack so there MUST be room */ \
- Push(Control_Point); \
- Push(Arg1); /* Function */ \
- Push(STACK_FRAME_HEADER+1);
-/* Pushed(); */
-\f
-#ifdef USE_STACKLETS
-#define CWCC_1() \
- Primitive_GC_If_Needed(2*Default_Stacklet_Size)
-
-#define CWCC_2() \
- Control_Point = Get_Current_Stacklet(); \
- Allocate_New_Stacklet(3)
-
-#else /* Not using stacklets, so full copy must be made */
-#define CWCC_1() \
- Primitive_GC_If_Needed((Stack_Top-Stack_Pointer) + \
- STACKLET_HEADER_SIZE - 1 + \
- CONTINUATION_SIZE + \
- HISTORY_SIZE)
-
-#define CWCC_2() \
-{ fast long i; \
- fast long Stack_Cells = (Stack_Top-Stack_Pointer); \
- Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \
- Free[STACKLET_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_VECTOR, \
- Stack_Cells + STACKLET_HEADER_SIZE - 1); \
- Free[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \
- Free += STACKLET_HEADER_SIZE; \
- for (i=0; i < Stack_Cells; i++) *Free++ = Pop(); \
- if (Consistency_Check) \
- if (Stack_Pointer != Stack_Top) \
- Microcode_Termination(TERM_BAD_STACK); \
- Will_Push(CONTINUATION_SIZE); \
- Store_Return(RC_JOIN_STACKLETS); \
- Store_Expression(Control_Point); \
- Save_Cont(); \
- Pushed(); \
-}
-#endif
-\f
-/* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE)
- Creates a control point (a pointer to the current stack) and
- passes it to PROCEDURE as its only argument. The inverse
- operation, typically called THROW, is performed by using the
- control point as you would a procedure. A control point accepts
- one argument which is then returned as the value of the CATCH
- which created the control point. If the dangerous bit of the
- unused length word in the stacklet is clear then the control
- point may be reused as often as desired since the stack will be
- copied on every throw. The user level CATCH is built on this
- primitive but is not the same, since it handles dynamic-wind
- while the primitive does not; it assumes that the microcode
- sets and clears the appropriate danger bits for copying.
-*/
-
-Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION", 0x3)
-{
- fast Pointer Control_Point;
-
- CWCC(RC_RESTORE_HISTORY);
- Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-Built_In_Primitive(Prim_Non_Reentrant_Catch, 1,
- "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9)
-{
- Pointer Control_Point;
-
-#ifdef USE_STACKLETS
-
- CWCC(RC_RESTORE_DONT_COPY_HISTORY);
-
-#else
- /* When there are no stacklets, it is identical to the reentrant version. */
-
- CWCC(RC_RESTORE_HISTORY);
- Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
-
-#endif
-
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* (ENABLE-INTERRUPTS! INTERRUPTS)
- Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
- and previous value of interrupts. Returns the previous value.
- See MASK_INTERRUPT_ENABLES for more information on interrupts.
-*/
-Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!", 0x1E)
-{
- Pointer Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Result = Make_Non_Pointer(TC_FIXNUM, IntEnb);
- IntEnb = Get_Integer(Arg1) | INT_Mask;
- New_Compiler_MemTop();
- return Result;
-}
-
-/* (ERROR-PROCEDURE arg1 arg2 arg3)
- Passes its arguments along to the appropriate Scheme error handler
- after turning off history, etc.
-*/
-Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE", 0x18E)
-{
- Primitive_3_Args();
-
- Will_Push(CONTINUATION_SIZE+HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
- Back_Out_Of_Primitive();
- Save_Cont();
- Stop_History();
- /* Stepping should be cleared here! */
- Push(Arg3);
- Push(Arg2);
- Push(Arg1);
- Push(Get_Fixed_Obj_Slot(Error_Procedure));
- Push(STACK_FRAME_HEADER+3);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-/* (GET-FIXED-OBJECTS-VECTOR)
- Returns the current fixed objects vector. This vector is used
- for communication between the interpreter and the runtime
- system. See the file UTABCSCM.SCM in the runtime system for the
- names of the slots in the vector.
-*/
-Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0,
- "GET-FIXED-OBJECTS-VECTOR", 0x7A)
-{
- Primitive_0_Args();
-
- if (Valid_Fixed_Obj_Vector())
- return Get_Fixed_Obj_Slot(Me_Myself);
- else return NIL;
-}
-\f
-/* (FORCE DELAYED-OBJECT)
- Returns the memoized value of the DELAYED-OBJECT (created by a
- DELAY special form) if it has already been calculated.
- Otherwise, it calculates the value and memoizes it for future
- use.
-*/
-Built_In_Primitive(Prim_Force, 1, "FORCE", 0xAF)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_DELAYED);
- if (Vector_Ref(Arg1, THUNK_SNAPPED) == TRUTH)
- return Vector_Ref(Arg1, THUNK_VALUE);
- Pop_Primitive_Frame(1);
- Will_Push(CONTINUATION_SIZE);
- Store_Return(RC_SNAP_NEED_THUNK);
- Store_Expression(Arg1);
- Save_Cont();
- Pushed();
- Store_Env(Fast_Vector_Ref(Arg1, THUNK_ENVIRONMENT));
- Store_Expression(Fast_Vector_Ref(Arg1, THUNK_PROCEDURE));
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
- /*NOTREACHED*/
-}
-\f
-/* (EXECUTE-AT-NEW-POINT SPACE BEFORE DURING AFTER)
- Create a new state point in the specified state SPACE. To enter
- the new point you must execute the BEFORE thunk. On the way out,
- the AFTER thunk is executed. If SPACE is NIL, then the microcode
- variable Current_State_Point is used to find the current state
- point and no state space is side-effected as the code runs.
-*/
-Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT", 0xE2)
-{
- Pointer New_Point, Old_Point;
- Primitive_4_Args();
-
- guarantee_state_point();
- if (Arg1 == NIL) Old_Point = Current_State_Point;
- else
- { Arg_1_Type(TC_VECTOR);
- if (Vector_Ref(Arg1, STATE_SPACE_TAG) !=
- Get_Fixed_Obj_Slot(State_Space_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Old_Point = Fast_Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
- }
- Primitive_GC_If_Needed(STATE_POINT_SIZE);
- Pop_Primitive_Frame(4);
- New_Point = Make_Pointer(TC_VECTOR, Free);
- Free[STATE_POINT_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1);
- Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
- Free[STATE_POINT_BEFORE_THUNK] = Arg2;
- Free[STATE_POINT_AFTER_THUNK] = Arg4;
- Free[STATE_POINT_NEARER_POINT] = Old_Point;
- Free[STATE_POINT_DISTANCE_TO_ROOT] =
- 1 + Fast_Vector_Ref(Old_Point, STATE_POINT_DISTANCE_TO_ROOT);
- Free += STATE_POINT_SIZE;
- Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
- /* Push a continuation to go back to the current state after the
- body is evaluated */
- Store_Expression(Old_Point);
- Store_Return(RC_RESTORE_TO_STATE_POINT);
- Save_Cont();
- /* Push a stack frame which will call the body after we have moved
- into the new state point */
- Push(Arg3);
- Push(STACK_FRAME_HEADER);
- /* Push the continuation to go with the stack frame */
- Store_Expression(NIL);
- Store_Return(RC_INTERNAL_APPLY);
- Save_Cont();
- Pushed();
- Translate_To_Point(New_Point);
-}
-\f
-/* (MAKE-STATE-SPACE MUTABLE?)
- Creates a new state space for the dynamic winder. Used only
- internally to the dynamic wind operations. If the arugment
- is #!TRUE, then a real, mutable state space is created.
- Otherwise a (actually, THE) immutable space is created and
- the microcode will track motions in this space.
-*/
-Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE", 0xE1)
-{
- Pointer New_Point;
- Primitive_1_Arg();
-
- Primitive_GC_If_Needed(STATE_POINT_SIZE+STATE_SPACE_SIZE);
- New_Point = Make_Pointer(TC_VECTOR, Free);
- Free[STATE_POINT_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_POINT_SIZE-1);
- Free[STATE_POINT_TAG] = Get_Fixed_Obj_Slot(State_Point_Tag);
- Free[STATE_POINT_BEFORE_THUNK] = NIL;
- Free[STATE_POINT_AFTER_THUNK] = NIL;
- Free[STATE_POINT_NEARER_POINT] = NIL;
- Free[STATE_POINT_DISTANCE_TO_ROOT] = Make_Unsigned_Fixnum(0);
- Free += STATE_POINT_SIZE;
- if (Arg1 == NIL)
- { Current_State_Point = New_Point;
- return NIL;
- }
- else
- { Pointer New_Space = Make_Pointer(TC_VECTOR, Free);
- Free[STATE_SPACE_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, STATE_SPACE_SIZE-1);
- Free[STATE_SPACE_TAG] = Get_Fixed_Obj_Slot(State_Space_Tag);
- Free[STATE_SPACE_NEAREST_POINT] = New_Point;
- Free += STATE_SPACE_SIZE;
- Fast_Vector_Set(New_Point, STATE_POINT_NEARER_POINT, New_Space);
- return New_Space;
- }
-}
-\f
-Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE", 0xA)
-{
- Primitive_1_Arg();
-
- guarantee_state_point();
- if (Arg1 == NIL) return Current_State_Point;
- Arg_1_Type(TC_VECTOR);
- if (Fast_Vector_Ref(Arg1, STATE_SPACE_TAG) !=
- Get_Fixed_Obj_Slot(State_Space_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
-}
-
-Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!", 0xB)
-{
- Pointer State_Space, Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_VECTOR);
- if (Fast_Vector_Ref(Arg1, STATE_POINT_TAG) !=
- Get_Fixed_Obj_Slot(State_Point_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- State_Space = Find_State_Space(Arg1);
- if (State_Space==NIL)
- {
- guarantee_state_point();
- Result = Current_State_Point;
- Current_State_Point = Arg1;
- }
- else
- {
- Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
- Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1);
- }
- return Result;
-}
-\f
-/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT)
- Evaluate the piece of SCode (SCODE-EXPRESSION) in the
- ENVIRONMENT. This is like Eval, except that it expects its input
- to be syntaxed into SCode rather than just a list.
-*/
-Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL", 0x4)
-{
- Primitive_2_Args();
-
- if (Type_Code(Arg2) != GLOBAL_ENV)
- Arg_2_Type(TC_ENVIRONMENT);
- Pop_Primitive_Frame(2);
- Store_Env(Arg2);
- Store_Expression(Arg1);
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
- /*NOTREACHED*/
-}
-
-/* (SET-INTERRUPT-ENABLES! NEW-INT-ENABLES)
- Changes the enabled interrupt bits to NEW-INT-ENABLES and
- returns the previous value. See MASK_INTERRUPT_ENABLES for more
- information on interrupts.
-*/
-Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!", 0x6)
-{
- Pointer Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- Result = Make_Unsigned_Fixnum(IntEnb);
- IntEnb = Get_Integer(Arg1) & INT_Mask;
- New_Compiler_MemTop();
- return Result;
-}
-\f
-/* (SET-CURRENT-HISTORY! TRIPLE)
- Begins recording history into TRIPLE. The history structure is
- somewhat complex and should be understood before trying to use
- this primitive. It is used in the Read-Eval-Print loop in the
- Scheme runtime system.
-
- This primitive pops its own frame and escapes back to the interpreter
- because it modifies one of the registers that the interpreter caches
- (History).
-
- The longjmp forces the interpreter to recache.
-*/
-Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F)
-{
- Primitive_1_Arg();
-
- /* History is one of the few places where we still used danger bits.
- Check explicitely.
- */
-
- if ((safe_pointer_type (Arg1)) != TC_HUNK3)
- error_wrong_type_arg_1 ();
-
- Val = *History;
-#ifdef COMPILE_HISTORY
- History = Get_Pointer(Arg1);
-#else
- History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History));
-#endif
- Pop_Primitive_Frame( 1);
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
- /*NOTREACHED*/
-}
-
-/* (SET-FIXED-OBJECTS-VECTOR! VECTOR)
- Replace the current fixed objects vector with VECTOR. The fixed
- objects vector is used for communication between the Scheme
- runtime system and the interpreter. The file UTABCSCM.SCM
- contains the names of the slots in the vector. Returns (bad
- style to depend on this) the previous fixed objects vector.
-*/
-Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1,
- "SET-FIXED-OBJECTS-VECTOR!", 0x7B)
-{
- Pointer Result;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_VECTOR);
- if (Valid_Fixed_Obj_Vector())
- Result = Get_Fixed_Obj_Slot(Me_Myself);
- else Result = NIL;
- Set_Fixed_Obj_Hook(Arg1);
- Set_Fixed_Obj_Slot(Me_Myself, Arg1);
- return Result;
-}
-\f
-/* (TRANSLATE-TO-STATE-POINT STATE_POINT)
- Move to a new dynamic wind environment by performing all of the
- necessary enter and exit forms to get from the current state to
- the new state as specified by STATE_POINT.
-*/
-Built_In_Primitive(Prim_Translate_To_Point, 1,
- "TRANSLATE-TO-STATE-POINT", 0xE3)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_VECTOR);
- if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag))
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Pop_Primitive_Frame(1);
- Translate_To_Point(Arg1);
- /* This ends by longjmp-ing back to the interpreter */
- /*NOTREACHED*/
-}
-
-/* (WITH-HISTORY-DISABLED THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. Turns off the history collection mechanism. Removes
- the most recent reduction (the expression which called the
- primitive) from the current history and saves the history. Then
- it calls the THUNK. When (if) the THUNK returns, the history is
- restored back and collection resumes. The net result is that the
- THUNK is called with history collection turned off.
-*/
-Built_In_Primitive(Prim_With_History_Disabled, 1,
- "WITH-HISTORY-DISABLED", 0x9C)
-{
- Pointer *First_Rib, *Rib, *Second_Rib;
- Primitive_1_Arg();
-
- /* Remove one reduction from the history before saving it */
- First_Rib = Get_Pointer(History[HIST_RIB]);
- Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]);
- if (!((Dangerous(First_Rib[RIB_MARK])) ||
- (First_Rib == Second_Rib)))
- { Set_Danger_Bit(Second_Rib[RIB_MARK]);
- for (Rib = First_Rib;
- Get_Pointer(Rib[RIB_NEXT_REDUCTION]) != First_Rib;
- Rib = Get_Pointer(Rib[RIB_NEXT_REDUCTION]))
- { /* Look for one that points to the first rib */ }
- History[HIST_RIB] = Make_Pointer(Type_Code(History[HIST_RIB]), Rib);
- }
- Pop_Primitive_Frame(1);
- Stop_History();
- Will_Push(STACK_ENV_EXTRA_SLOTS+1);
- Push(Arg1);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* Called with a mask and a thunk */
-
-Built_In_Primitive(Prim_With_Interrupt_Mask, 2,
- "WITH-INTERRUPT-MASK", 0x137)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Pop_Primitive_Frame(2);
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- IntEnb = INT_Mask & Get_Integer(Arg1);
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-/* Called with a mask and a thunk */
-
-Built_In_Primitive(Prim_With_Interrupts_Reduced, 2,
- "WITH-INTERRUPTS-REDUCED", 0xC9)
-{
- long new_interrupt_mask;
- Primitive_2_Args();
- Arg_1_Type(TC_FIXNUM);
- Pop_Primitive_Frame(2);
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- new_interrupt_mask = (INT_Mask & Get_Integer( Arg1));
- if (new_interrupt_mask > IntEnb)
- IntEnb = new_interrupt_mask;
- else
- IntEnb = (new_interrupt_mask & IntEnb);
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. Restores the state of the machine from the control
- point, and then calls the THUNK in this new state.
-*/
-Built_In_Primitive(Prim_Within_Control_Point, 2,
- "WITHIN-CONTROL-POINT", 0xBF)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_CONTROL_POINT);
- Our_Throw(false, Arg1);
- Within_Stacklet_Backout();
- Our_Throw_Part_2();
- Will_Push(STACK_ENV_EXTRA_SLOTS+1);
- Push(Arg2);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-/* (WITH-THREADED-CONTINUATION PROCEDURE THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. PROCEDURE must expect one argument. Basically this
- primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and
- passes the result on as an argument to PROCEDURE. However, it
- leaves a "well-known continuation code" on the stack for use by
- the continuation parser in the Scheme runtime system.
-*/
-Built_In_Primitive(Prim_With_Threaded_Stack, 2,
- "WITH-THREADED-CONTINUATION", 0xBE)
-{
- Primitive_2_Args();
-
- Pop_Primitive_Frame(2);
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
- Store_Expression(Arg1); /* Save procedure to call later */
- Store_Return(RC_INVOKE_STACK_THREAD);
- Save_Cont();
- Push(Arg2); /* Function to call now */
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.22 1987/04/16 02:24:07 jinx Rel $
- *
- * Support for Hunk3s (triples)
- */
-
-#include "scheme.h"
-#include "primitive.h"
-
-/* (HUNK3-CONS FIRST SECOND THIRD)
- Returns a triple consisting of the specified values.
-*/
-Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS", 0x28)
-{
- Primitive_3_Args();
-
- Primitive_GC_If_Needed(3);
- *Free++ = Arg1;
- *Free++ = Arg2;
- *Free++ = Arg3;
- return Make_Pointer(TC_HUNK3, Free-3);
-}
-\f
-/* (HUNK3-CXR TRIPLE N)
- Returns the Nth item from the TRIPLE. N must be 0, 1, or 2.
-*/
-Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR", 0x29)
-{
- long Offset;
- Primitive_2_Args();
-
- Arg_1_Type(TC_HUNK3);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
- return Vector_Ref(Arg1, Offset);
-}
-
-/* (HUNK3-SET-CXR! TRIPLE N VALUE)
- Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2.
- Returns (not good style to count on this) the previous contents.
-*/
-Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!", 0x2A)
-{
- long Offset;
- Primitive_3_Args();
-
- Arg_1_Type(TC_HUNK3);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
- Side_Effect_Impurify(Arg1, Arg3);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset), Arg3);
-}
-\f
-/* (SYSTEM-HUNK3-CXR0 GC-TRIPLE)
- Returns item 0 (the first item) from any object with a GC type
- of triple. For example, this would access the operator slot of
- a COMBINATION_2_OPERAND SCode item.
-*/
-Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0", 0x8E)
-{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 0);
-}
-
-/* (SYSTEM-HUNK3-CXR1 GC-TRIPLE)
- Returns item 1 (the second item) from any object with a GC type
- of triple. For example, this would access the first operand
- slot of a COMBINATION_2_OPERAND SCode item.
-*/
-Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1", 0x91)
-{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 1);
-}
-
-/* (SYSTEM-HUNK3-CXR2 GC-TRIPLE)
- Returns item 2 (the third item) from any object with a GC type
- of triple. For example, this would access the second operand
- slot of a COMBINATION_2_OPERAND SCode item.
-*/
-Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2", 0x94)
-{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Triple);
- return Vector_Ref(Arg1, 2);
-}
-\f
-/* (SYSTEM-HUNK3-SET-CXR0! GC-TRIPLE NEW-CONTENTS)
- Replaces item 0 (the first item) in any object with a GC type of
- triple with NEW-CONTENTS. For example, this would modify the
- operator slot of a COMBINATION_2_OPERAND SCode item. Returns
- (bad style to rely on this) the previous contents.
-*/
-Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F)
-{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 0), Arg2);
-}
-
-/* (SYSTEM-HUNK3-SET-CXR1! GC-TRIPLE NEW-CONTENTS)
- Replaces item 1 (the second item) in any object with a GC type
- of triple with NEW-CONTENTS. For example, this would modify the
- first operand slot of a COMBINATION_2_OPERAND SCode item.
- Returns (bad style to rely on this) the previous contents.
-*/
-Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92)
-{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 1), Arg2);
-}
-\f
-/* (SYSTEM-HUNK3-SET-CXR2! GC-TRIPLE NEW-CONTENTS)
- Replaces item 2 (the third item) in any object with a GC type of
- triple with NEW-CONTENTS. For example, this would modify the
- second operand slot of a COMBINATION_2_OPERAND SCode item.
- Returns (bad style to rely on this) the previous contents.
-*/
-Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!", 0x95)
-{
- Primitive_2_Args();
- Arg_1_GC_Type(GC_Triple);
-
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, 2), Arg2);
-}
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.c,v 9.21 1987/01/22 14:27:21 jinx Rel $ */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "flonum.h"
-#include "array.h"
-#include <math.h>
-\f
-/* IMAGE PROCESSING... */
-/* (much comes from array.c) */
-
-Define_Primitive(Prim_Read_Image_From_Ascii_File, 1, "READ-IMAGE-FROM-ASCII-FILE")
-{ long Length, int_pixel_value1, int_pixel_value2, i, j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *To_Here;
- REAL *From_Here_1, *From_Here_2;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- fscanf(fp, "%d %d \n", &nrows, &ncols);
- if ((ncols > 512) || (nrows>512)) {
- printf("read-image-ascii-file: ncols, nrows must be <= 512\n");
- return(NIL);
- }
- Length = nrows * ncols;
- printf("nrows is %d \n", nrows);
- printf("ncols is %d \n", ncols);
- printf("Reading data file ...\n");
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
-
- /* Allocate_Array(Array_Data_Result, Length, allocated_cells); */
- allocated_cells = (Length*REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
- Array_Data_Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = Length;
- Free = Free+allocated_cells;
-
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
-
- for (i=0; i<Length; i++)
- { fscanf( fp, "%d%d", &int_pixel_value1, &int_pixel_value2);
- *To_Here++ = ((REAL) int_pixel_value1);
- *To_Here++ = ((REAL) int_pixel_value2); /* faster reading ? */
- }
- printf("File read. Length is %d \n", i);
- Close_File(fp);
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Read_Image_From_Cbin_File, 1, "READ-IMAGE-FROM-CBIN-FILE")
-{ long Length, i,j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *To_Here;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
- nrows = getw(fp); ncols = getw(fp);
- Length = nrows * ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
-
- /* READING IN BIN int FORMAT */
- for (i=0;i<Length;i++) {
- if (feof(fp)!=0) { printf("not enough values read, last read i-1 %d , value %d\n", (i-1), *(To_Here-1));
- return NIL; }
- *To_Here++ = ((REAL) getw(fp));
- }
-
- Close_File(fp);
- return Result;
-}
-\f
-Define_Primitive(Prim_Read_Image_From_CTSCAN_File, 1, "READ-IMAGE-FROM-CTSCAN-FILE")
-{ long Length, i,j;
- long nrows, ncols, array_index;
- FILE *fopen(), *fp;
- char *file_string;
- REAL *Array;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
- Boolean Open_File();
-
- Primitive_1_Args();
- Arg_1_Type(TC_CHARACTER_STRING);
-
- if (!(Open_File(Arg1, "r", &fp))) Primitive_Error(ERR_ARG_1_BAD_RANGE);
- if (feof(fp)!=0) { printf("Datafile is empty!"); return NIL; }
- nrows = 512; ncols = 512;
- Length = nrows * ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- Array = Scheme_Array_To_C_Array(Array_Data_Result);
- Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols);
- Close_File(fp);
- return Result;
-}
-\f
-Image_Read_From_CTSCAN_File(fp,Array,nrows,ncols)
- FILE *fp; REAL *Array; long nrows,ncols;
-{ int i,m;
- long Length=nrows*ncols;
- int first_header_bytes = 2048;
- int second_header_bytes = 3150-(2048+1024);
- int word1, word2;
- long number;
- int *Widths;
- char ignore;
- REAL *Temp_Row;
- int array_index;
-
- Primitive_GC_If_Needed(512); /* INTEGER_SIZE is = 1 scheme pointer */
- Widths = ((int *) Free);
- for (i=0;i<first_header_bytes;i++) ignore = getc(fp);
- for (i = 0; i<512; i++) {
- word1 = ((int) getc(fp));
- word2 = ((int) getc(fp));
- number = ((word1<<8) | word2); /* bitwise inclusive or */
- Widths[i] = number; /* THESE ARE HALF THE NROW-WIDTHs ! */
- }
-
- for (i=0;i<Length;i++) Array[i] = 0; /* initialize with zeros */
-
- for (i = 0; i<512; i++) {
- array_index = i*512 + (256-Widths[i]); /* note the offset */
- for (m=array_index; m<(array_index + 2*Widths[i]); m++) {
- word1 = ((int) getc(fp)); word2 = ((int) getc(fp));
- number = ((word1<<8) | word2); /* bitwise inclusive or */
- Array[m] = ((REAL) number); /* do I need to explicitly sign-extend? */
- }
- }
- Primitive_GC_If_Needed(512*REAL_SIZE);
- Temp_Row = ((REAL *) Free);
- Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row); /* CTSCAN images are upside down */
-}
-\f
-Image_Mirror_Upside_Down(Array,nrows,ncols,Temp_Row)
- REAL *Array, *Temp_Row; long nrows,ncols;
-{ int i;
- REAL *M_row, *N_row;
- for (i=0;i<(nrows/2);i++) {
- M_row = Array + (i * ncols);
- N_row = Array + (((nrows-1)-i) * ncols);
- C_Array_Copy(N_row, Temp_Row, ncols);
- C_Array_Copy(M_row, N_row, ncols);
- C_Array_Copy(Temp_Row, M_row, ncols);
- }
-}
-\f
-Define_Primitive(Prim_Subimage, 5, "SUBIMAGE")
-{ long Length, new_Length;
- long i,j;
- Pointer Pnrows, Pncols, Prest, Parray;
- long lrow, hrow, lcol, hcol;
- long nrows, ncols, new_nrows, new_ncols;
-
- REAL *Array, *To_Here;
- Pointer Result, Array_Data_Result, *Orig_Free;
- int Error_Number;
- long allocated_cells;
-
- Primitive_5_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
-
- Range_Check(lrow, Arg2, 0, nrows, ERR_ARG_2_BAD_RANGE);
- Range_Check(hrow, Arg3, lrow, nrows, ERR_ARG_3_BAD_RANGE);
- Range_Check(lcol, Arg4, 0, ncols, ERR_ARG_4_BAD_RANGE);
- Range_Check(hcol, Arg5, lcol, ncols, ERR_ARG_5_BAD_RANGE);
- new_nrows = hrow - lrow +1;
- new_ncols = hcol - lcol +1;
- new_Length = new_nrows * new_ncols;
-
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, new_nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, new_ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, new_Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- Array = Scheme_Array_To_C_Array(Parray);
- To_Here = Scheme_Array_To_C_Array(Array_Data_Result);
- for (i=lrow; i<=hrow; i++) {
- for (j=lcol; j<=hcol; j++) {
- *To_Here++ = Array[i*ncols+j]; /* A(i,j)--->Array[i*ncols+j] */
- }}
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Image_Double_To_Float, 1, "IMAGE-DOUBLE-TO-FLOAT!")
-{ long Length;
- long i,j;
- long nrows, ncols;
- long allocated_cells;
- double *Array, *From_Here;
- register double temp_value_cell;
- float *To_Here;
- int Error_Number;
- Pointer Pnrows,Pncols,Parray,Prest;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 2048, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 2048, ERR_ARG_1_BAD_RANGE);
-
- Array = ((double *) (Nth_Vector_Loc(Parray, ARRAY_DATA)));
- From_Here = Array;
- To_Here = ((float *) (Array));
- Length = nrows * ncols;
-
- for (i=0;i<Length;i++) {
- temp_value_cell = *From_Here;
- From_Here++;
- *To_Here = ((float) temp_value_cell);
- To_Here++;
- }
-
- /* and now SIDE-EFFECT the ARRAY_HEADER */
- allocated_cells = (Length *
- ((sizeof(Pointer)+sizeof(float)-1) / sizeof(Pointer)) +
- ARRAY_HEADER_SIZE);
- *(Nth_Vector_Loc(Parray, ARRAY_HEADER)) =
- Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- /* see array.h to understand the above */
-
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Image_Set_Row, 3, "IMAGE-SET-ROW!")
-{ long Length, i,j;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols, row_to_set;
- REAL *Array, *Row_Array;
-
- Primitive_3_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
-
- Arg_2_Type(TC_FIXNUM);
- Range_Check(row_to_set, Arg2, 0, (nrows-1), ERR_ARG_2_BAD_RANGE);
- Arg_3_Type(TC_ARRAY);
- Row_Array = Scheme_Array_To_C_Array(Arg3);
- if (Array_Length(Arg3)>ncols) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Parray);
- C_Image_Set_Row(Array, row_to_set, Row_Array, nrows, ncols);
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Image_Set_Column, 3, "IMAGE-SET-COLUMN!")
-{ long Length, i,j;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols, col_to_set;
- REAL *Array, *Col_Array;
-
- Primitive_3_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
-
- Arg_2_Type(TC_FIXNUM);
- Range_Check(col_to_set, Arg2, 0, (nrows-1), ERR_ARG_2_BAD_RANGE);
- Arg_3_Type(TC_ARRAY);
- Col_Array = Scheme_Array_To_C_Array(Arg3);
- if (Array_Length(Arg3)>ncols) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Parray);
- C_Image_Set_Col(Array, col_to_set, Col_Array, nrows, ncols);
- return Arg1;
-}
-\f
-C_Image_Set_Row(Image_Array, row_to_set, Row_Array, nrows, ncols) REAL *Image_Array, *Row_Array;
-long nrows, ncols, row_to_set;
-{ long j;
- REAL *From_Here, *To_Here;
-
- To_Here = &Image_Array[row_to_set*ncols];
- From_Here = Row_Array;
- for (j=0;j<ncols;j++)
- *To_Here++ = *From_Here++;
-}
-\f
-C_Image_Set_Col(Image_Array, col_to_set, Col_Array, nrows, ncols) REAL *Image_Array, *Col_Array;
-long nrows, ncols, col_to_set;
-{ long i;
- REAL *From_Here, *To_Here;
-
- To_Here = &Image_Array[col_to_set];
- From_Here = Col_Array;
- for (i=0;i<nrows;i++) {
- *To_Here = *From_Here++;
- To_Here += nrows;
- }
-}
-
-\f
-Define_Primitive(Prim_Image_Make_Ring, 4, "IMAGE-MAKE-RING")
-{ long Length, i,j;
- long nrows, ncols;
- long Min_Cycle=0, Max_Cycle=min((nrows/2),(ncols/2));
- long low_cycle, high_cycle;
- REAL *Ring_Array;
- Pointer Result, Ring_Array_Result, *Orig_Free;
- long allocated_cells;
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Range_Check(nrows, Arg1, 0, 512, ERR_ARG_1_BAD_RANGE);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(ncols, Arg2, 0, 512, ERR_ARG_2_BAD_RANGE);
- Length = nrows*ncols;
- Arg_3_Type(TC_FIXNUM);
- Range_Check(low_cycle, Arg3, Min_Cycle, Max_Cycle, ERR_ARG_2_BAD_RANGE);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(high_cycle, Arg4, Min_Cycle, Max_Cycle, ERR_ARG_3_BAD_RANGE);
- if (high_cycle<low_cycle) Primitive_Error(ERR_ARG_3_BAD_RANGE);
-\f
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Ring_Array_Result, Length, allocated_cells);
- *Orig_Free++ = Ring_Array_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- Ring_Array = Scheme_Array_To_C_Array(Ring_Array_Result);
- C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle);
- return Result;
-}
-\f
-C_Image_Make_Ring(Ring_Array, nrows, ncols, low_cycle, high_cycle) REAL *Ring_Array;
-long nrows, ncols, low_cycle, high_cycle;
-{ long Square_LC=low_cycle*low_cycle, Square_HC=high_cycle*high_cycle;
- long i, j, m, n, radial_cycle;
- long nrows2=nrows/2, ncols2=ncols/2;
- for (i=0; i<nrows; i++) {
- for (j=0; j<ncols; j++) {
- m = ((i<nrows2) ? i : (nrows-i));
- n = ((j<ncols2) ? j : (ncols-j));
- radial_cycle = (m*m)+(n*n);
- if ( (radial_cycle<Square_LC) || (radial_cycle>Square_HC))
- Ring_Array[i*ncols+j] = 0;
- else Ring_Array[i*ncols+j] = 1;
- }}
-}
-
-\f
-/* DONE WITHOUT SIDE-EFFECTS FOR SIMPLICITY */
-Define_Primitive(Prim_Image_Periodic_Shift, 3, "IMAGE-PERIODIC-SHIFT")
-{ long Length, i,j;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- long hor_shift, ver_shift;
- REAL *Array, *New_Array;
- Pointer Result, Array_Data_Result, *Orig_Free;
- long allocated_cells;
-
- Primitive_3_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Arg_2_Type(TC_FIXNUM);
- Sign_Extend(Arg2, ver_shift);
- ver_shift = ver_shift % nrows;
- Arg_3_Type(TC_FIXNUM);
- Sign_Extend(Arg3, hor_shift);
- hor_shift = hor_shift % ncols;
-\f
- /* ALLOCATE SPACE */
- Primitive_GC_If_Needed(6);
- Orig_Free = Free;
- Free += 6;
- Result = Make_Pointer(TC_LIST, Orig_Free);
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, nrows);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- *Orig_Free++ = Make_Non_Pointer(TC_FIXNUM, ncols);
- *Orig_Free = Make_Pointer(TC_LIST, Orig_Free+1);
- Orig_Free++;
- Allocate_Array(Array_Data_Result, Length, allocated_cells);
- *Orig_Free++ = Array_Data_Result;
- *Orig_Free = NIL;
- /* END ALLOCATION */
-
- Array = Scheme_Array_To_C_Array(Parray);
- New_Array = Scheme_Array_To_C_Array(Array_Data_Result);
- C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift);
- return Result;
-}
-\f
-/* ASSUMES hor_shift<nrows, ver_shift<ncols */
-C_Image_Periodic_Shift(Array, New_Array, nrows, ncols, ver_shift, hor_shift)
- REAL *Array, *New_Array; long nrows, ncols, hor_shift, ver_shift;
-{ long i, j, ver_index, hor_index;
- REAL *To_Here;
- To_Here = New_Array;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- ver_index = (i+ver_shift) % nrows;
- if (ver_index<0) ver_index = nrows-ver_index; /* wrapping around */
- hor_index = (j+hor_shift) % ncols;
- if (hor_index<0) hor_index = ncols-hor_index;
- *To_Here++ = Array[ver_index*ncols + hor_index];
- }}
-}
-
-\f
-/* ROTATIONS..... */
-
-Define_Primitive(Prim_Image_Transpose, 1, "IMAGE-TRANSPOSE!")
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Parray);
-
- if (nrows==ncols) {
- Image_Fast_Transpose(Array, nrows); /* side-effecting ... */
- }
- else {
- REAL *New_Array;
- long Length=nrows*ncols;
- Primitive_GC_If_Needed(Length*REAL_SIZE); /* making space in scheme heap */
- New_Array = ((REAL *) Free);
- Image_Transpose(Array, New_Array, nrows, ncols);
- C_Array_Copy(New_Array, Array, Length);
- }
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Image_Rotate_90clw, 1, "IMAGE-ROTATE-90CLW!")
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Temp_Array = ((REAL *) Free);
- Array = Scheme_Array_To_C_Array(Parray);
- Image_Rotate_90clw(Array, Temp_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Array, Length);
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Image_Rotate_90cclw, 1, "IMAGE-ROTATE-90CCLW!")
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Primitive_GC_If_Needed(Length*REAL_SIZE);
- Temp_Array = ((REAL *) Free);
- Array = Scheme_Array_To_C_Array(Parray);
- Image_Rotate_90cclw(Array, Temp_Array, nrows, ncols);
- C_Array_Copy(Temp_Array, Array, Length);
-
- Vector_Set(Arg1, CONS_CAR, Make_Pointer(TC_FIXNUM, ncols) ); /* swithing nrows, ncols */
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Vector_Set(Prest, CONS_CAR, Make_Pointer(TC_FIXNUM, nrows) );
- return Arg1;
-}
-\f
-Define_Primitive(Prim_Image_Mirror, 1, "IMAGE-MIRROR!")
-{ long Length;
- Pointer Pnrows, Pncols, Prest, Parray;
- long nrows, ncols;
- REAL *Array, *Temp_Array;
-
- Primitive_1_Args();
- Arg_1_Type(TC_LIST); /* image = (nrows ncols array) */
-
- Pnrows = Vector_Ref(Arg1, CONS_CAR);
- Prest = Vector_Ref(Arg1, CONS_CDR);
- Pncols = Vector_Ref(Prest, CONS_CAR);
- Prest = Vector_Ref(Prest, CONS_CDR);
- Parray = Vector_Ref(Prest, CONS_CAR);
- if (Vector_Ref(Prest, CONS_CDR) != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- if (Type_Code(Parray) != TC_ARRAY) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- Range_Check(nrows, Pnrows, 0, 512, ERR_ARG_1_BAD_RANGE);
- Range_Check(ncols, Pncols, 0, 512, ERR_ARG_1_BAD_RANGE);
- Length = nrows*ncols;
-
- Array = Scheme_Array_To_C_Array(Parray);
- C_Mirror_Image(Array, nrows, ncols); /* side-effecting... */
-
- return Arg1;
-}
-\f
-
-/* THE C ROUTINES THAT DO THE REAL WORK */
-
-/*
- IMAGE_FAST_TRANSPOSE
- A(i,j) <-> A(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Fast_Transpose(Array, nrows) /* for square images */
- REAL *Array; long nrows;
-{ long i, j;
- long from, to;
- REAL temp;
- for (i=0;i<nrows;i++) {
- for (j=i;j<nrows;j++) {
- from = i*nrows + j;
- to = j*nrows + i; /* (columns transposed-image) = ncols */
- temp = Array[from];
- Array[from] = Array[to];
- Array[to] = temp;
- }}
-}
-\f
-/*
- IMAGE_TRANSPOSE
- A(i,j) -> B(j,i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns .
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Transpose(Array, New_Array, nrows, ncols)
- REAL *Array, *New_Array; long nrows, ncols;
-{ long i, j;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- New_Array[j*nrows + i] = Array[i*ncols + j]; /* (columns transposed-image) = nrows */
- }}
-}
-\f
-/*
- IMAGE_ROTATE_90CLW
- A(i,j) <-> A(j, (nrows-1)-i) .
- UNWRAP: A(i,j) ----> Array[i*ncols + j] convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Rotate_90clw(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
-{ long i, j;
-
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- Rotated_Array[(j*nrows) + ((nrows-1)-i)] = Array[i*ncols+j]; /* (columns rotated_image) =nrows */
- }}
-}
-\f
-/*
- ROTATION 90degrees COUNTER-CLOCK-WISE:
- A(i,j) <-> A((nrows-1)-j, i) . (minus 1 because we start from 0).
- UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-Image_Rotate_90cclw(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
-{ long i, j;
- register long from_index, to_index;
- long Length=nrows*ncols;
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- from_index = i*ncols +j;
- to_index = ((ncols-1)-j)*nrows + i; /* (columns rotated-image) = nrows */
- Rotated_Array[to_index] = Array[from_index];
- }}
-}
-\f
-/*
- IMAGE_MIRROR:
- A(i,j) <-> A(i, (ncols-1)-j) [ The -1 is there because we count from 0] .
- A(i,j) -------> Array[i*ncols + j] fix row, read column convention.
- */
-C_Mirror_Image(Array, nrows, ncols) REAL *Array; long nrows, ncols;
-{ long i, j;
- long ncols2=ncols/2, Length=nrows*ncols;
- REAL temp;
- long from, to;
-
- for (i=0; i<Length; i += ncols) {
- for (j=0; j<ncols2; j++) { /* DO NOT UNDO the reflections */
- from = i + j; /* i is really i*nrows */
- to = i + (ncols-1)-j;
- temp = Array[from];
- Array[from] = Array[to];
- Array[to] = temp;
- }}
-}
-
-
-\f
-/*
- IMAGE_ROTATE_90CLW_MIRROR:
- A(i,j) <-> A(j, i) this should be identical to image_transpose (see above).
- UNWRAP: A(i,j) ----> Array[i*ncols + j] because of convention:= fix row & go by columns
- UNWRAP is a bijection from the compact plane to the compact interval.
- */
-C_Rotate_90clw_Mirror_Image(Array, Rotated_Array, nrows, ncols)
- REAL *Array, *Rotated_Array; long nrows, ncols;
-{ long i, j;
- long from, to, Length=nrows*ncols;
-
- for (i=0;i<nrows;i++) {
- for (j=0;j<ncols;j++) {
- from = i*ncols +j;
- to = j*nrows +i; /* the columns of the rotated image are nrows! */
- Rotated_Array[to] = Array[from];
- }}
-}
-\f
-
-
-
-
-/* END */
-
-
-
-
-
-
-/*
-\f
-Define_Primitive(Prim_Sample_Periodic_2d_Function, 4, "SAMPLE-PERIODIC-2D-FUNCTION")
-{ long N, i, allocated_cells, Function_Number;
- REAL Signal_Frequency, Sampling_Frequency, DT, DTi;
- REAL twopi = 6.28318530717958, twopi_f_dt;
- Pointer Result, Pfunction_number, Psignal_frequency;
- Pointer Pfunction_Number;
- int Error_Number;
- REAL *To_Here, unit_square_wave(), unit_triangle_wave();
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); / * fix this * /
-
- Error_Number = Scheme_Number_To_REAL(Arg2, &Signal_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_REAL(Arg3, &Sampling_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- DT = (1 / Sampling_Frequency);
- twopi_f_dt = twopi * Signal_Frequency * DT;
-
- Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
-
- allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
-
- Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = N;
- To_Here = Scheme_Array_To_C_Array(Result);
- Free = Free+allocated_cells;
-
- DT = twopi_f_dt;
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = cos(DTi);
- else if (Function_Number == 1)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = sin(DTi);
- else if (Function_Number == 2)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = unit_square_wave(DTi);
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = unit_triangle_wave(DTi);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
-}
-
-*/
-/* END IMAGE PROCESSING */
-
-
-\f
-/* Note for the macro: To1 and To2 must BE Length1-1, and Length2-2 RESPECTIVELY ! */
-/*
-#define C_Convolution_Point_Macro(X, Y, To1, To2, N, Result) \
-{ long Min_of_N_To1=min((N),(To1)); \
- long mi, N_minus_mi; \
- REAL Sum=0.0; \
- for (mi=max(0,(N)-(To2)), N_minus_mi=(N)-mi; mi <= Min_of_N_To1; mi++, N_minus_mi--) \
- Sum += (X[mi] * Y[N_minus_mi]); \
- (Result)=Sum; \
-}
-\f
-Define_Primitive(Prim_Convolution_Point, 3, "CONVOLUTION-POINT")
-{ long Length1, Length2, N;
- REAL *Array1, *Array2;
- REAL C_Result;
-
- Primitive_3_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Arg_3_Type(TC_FIXNUM);
- Length1 = Array_Length(Arg1);
- Length2 = Array_Length(Arg2);
- N = Get_Integer(Arg3);
- Array1 = Scheme_Array_To_C_Array(Arg1);
- Array2 = Scheme_Array_To_C_Array(Arg2);
- C_Convolution_Point_Macro(Array1, Array2, Length1-1, Length2-1, N, C_Result);
- Reduced_Flonum_Result(C_Result);
-}
-\f
-Define_Primitive(Prim_Array_Convolution, 2, "ARRAY-CONVOLUTION")
-{ long Endpoint1, Endpoint2, allocated_cells, i;
- / * ASSUME A SIGNAL FROM INDEX 0 TO ENDPOINT=LENGTH-1 * /
- long Resulting_Length;
- REAL *Array1, *Array2, *To_Here;
- Pointer Result;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_ARRAY);
- Endpoint1 = Array_Length(Arg1) - 1;
- Endpoint2 = Array_Length(Arg2) - 1;
- Resulting_Length = Endpoint1 + Endpoint2 + 1;
- Array1 = Scheme_Array_To_C_Array(Arg1);
- Array2 = Scheme_Array_To_C_Array(Arg2);
-
- allocated_cells = (Resulting_Length * REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
- Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = Resulting_Length;
- Free += allocated_cells;
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Resulting_Length; i++) {
- C_Convolution_Point_Macro(Array1, Array2, Endpoint1, Endpoint2, i, *To_Here);
- To_Here++;
- }
- return Result;
-}
-*/
-
-/* m_pi = 3.14159265358979323846264338327950288419716939937510; */
-
-/*
-Define_Primitive(Prim_Sample_Periodic_Function, 4, "SAMPLE-PERIODIC-FUNCTION")
-{ long N, i, allocated_cells, Function_Number;
- REAL Signal_Frequency, Sampling_Frequency, DT, DTi;
- REAL twopi = 6.28318530717958, twopi_f_dt;
- Pointer Result, Pfunction_number, Psignal_frequency;
- Pointer Pfunction_Number;
- int Error_Number;
- REAL *To_Here, unit_square_wave(), unit_triangle_wave();
-
- Primitive_4_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_4_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 10, ERR_ARG_1_BAD_RANGE); / * fix this * /
-
- Error_Number = Scheme_Number_To_REAL(Arg2, &Signal_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Signal_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_REAL(Arg3, &Sampling_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- DT = (1 / Sampling_Frequency);
- twopi_f_dt = twopi * Signal_Frequency * DT;
-
- Range_Check(N, Arg4, 0, ARRAY_MAX_LENGTH, ERR_ARG_4_BAD_RANGE);
-
- allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
-
- Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = N;
- To_Here = Scheme_Array_To_C_Array(Result);
- Free = Free+allocated_cells;
-
- DT = twopi_f_dt;
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = cos(DTi);
- else if (Function_Number == 1)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = sin(DTi);
- else if (Function_Number == 2)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = unit_square_wave(DTi);
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = unit_triangle_wave(DTi);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
-}
-\f
-REAL hamming(t, length) REAL t, length;
-{ REAL twopi = 6.28318530717958;
- REAL pi = twopi/2.;
- REAL t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0)) return(.08 + .46 * (1 - t_bar));
- else return (0);
-}
-\f
-REAL hanning(t, length) REAL t, length;
-{ REAL twopi = 6.28318530717958;
- REAL pi = twopi/2.;
- REAL t_bar = cos(twopi * (t / length));
- if ((t<length) && (t>0.0))
- return(.5 * (1 - t_bar));
- else return (0);
-}
-\f
-REAL unit_square_wave(t) REAL t;
-{ REAL twopi = 6.28318530717958;
- REAL fmod(), fabs();
- REAL pi = twopi/2.;
- REAL t_bar = fabs(fmod(t, twopi));
- if (t_bar < pi) return(1);
- else return(0);
-}
-\f
-REAL unit_triangle_wave(t) REAL t;
-{ REAL twopi = 6.28318530717958;
- REAL pi = twopi/2.;
- REAL t_bar = fabs(fmod(t, twopi));
- if (t_bar < pi) return( t_bar / pi );
- else return( (twopi - t_bar) / pi );
-}
-\f
-Define_Primitive(Prim_Sample_Aperiodic_Function, 3, "SAMPLE-APERIODIC-FUNCTION")
-{ long N, i, allocated_cells, Function_Number;
- REAL Sampling_Frequency, DT, DTi;
- REAL twopi = 6.28318530717958;
- Pointer Result;
- int Error_Number;
- REAL *To_Here, twopi_dt;
-
- Primitive_3_Args();
- Arg_1_Type(TC_FIXNUM);
- Arg_3_Type(TC_FIXNUM);
- Range_Check(Function_Number, Arg1, 0, 6, ERR_ARG_1_BAD_RANGE);
-
- Error_Number = Scheme_Number_To_REAL(Arg2, &Sampling_Frequency);
- if (Error_Number == 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- if (Error_Number == 2) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Sampling_Frequency == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- DT = (1 / Sampling_Frequency);
- twopi_dt = twopi * DT;
-
- Range_Check(N, Arg3, 0, ARRAY_MAX_LENGTH, ERR_ARG_3_BAD_RANGE);
-
- allocated_cells = (N*REAL_SIZE) + ARRAY_HEADER_SIZE;
- Primitive_GC_If_Needed(allocated_cells);
-
- Result = Make_Pointer(TC_ARRAY, Free);
- Free[ARRAY_HEADER] = Make_Non_Pointer(TC_MANIFEST_ARRAY, allocated_cells-1);
- Free[ARRAY_LENGTH] = N;
- To_Here = Scheme_Array_To_C_Array(Result);
- Free = Free+allocated_cells;
-
- DT = twopi_dt;
- if (Function_Number == 0)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = rand();
- else if (Function_Number == 1)
- { REAL length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = hanning(DTi, length);
- }
- else if (Function_Number == 2)
- { REAL length=DT*N;
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = hamming(DTi, length);
- }
- else if (Function_Number == 3)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = sqrt(DTi);
- else if (Function_Number == 4)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = log(DTi);
- else if (Function_Number == 5)
- for (i=0, DTi=0.0; i < N; i++, DTi += DT)
- *To_Here++ = exp(DTi);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Periodic_Downsample, 2, "ARRAY-PERIODIC-DOWNSAMPLE")
-{ long Length, Pseudo_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
-
- Sign_Extend(Arg2, Sampling_Ratio); / * Sampling_Ratio = integer ratio of sampling_frequencies * /
- Sampling_Ratio = Sampling_Ratio % Length; / * periodicity * /
- if (Sampling_Ratio < 1) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- Pseudo_Length = Length * Sampling_Ratio;
- for (i=0; i<Pseudo_Length; i += Sampling_Ratio) { / * new Array has the same Length by assuming periodicity * /
- array_index = i % Length;
- *To_Here++ = Array[array_index];
- }
-
- return Result;
-}
-\f
-Define_Primitive(Prim_Array_Periodic_Shift, 2, "ARRAY-PERIODIC-SHIFT")
-{ long Length, Shift;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Sign_Extend(Arg2, Shift);
- Shift = Shift % Length; / * periodic waveform, same sign as dividend * /
- Array = Scheme_Array_To_C_Array(Arg1);
- Allocate_Array(Result, Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Length; i++) { / * new Array has the same Length by assuming periodicity * /
- array_index = (i+Shift) % Length;
- if (array_index<0) array_index = Length + array_index; / * wrap around * /
- *To_Here++ = Array[array_index];
- }
-
- return Result;
-}
-\f
-/ * this should really be done in SCHEME using ARRAY-MAP ! * /
-
-Define_Primitive(Prim_Array_Aperiodic_Downsample, 2, "ARRAY-APERIODIC-DOWNSAMPLE")
-{ long Length, New_Length, Sampling_Ratio;
- REAL *Array, *To_Here;
- Pointer Result;
- long allocated_cells, i, array_index;
-
- Primitive_2_Args();
- Arg_1_Type(TC_ARRAY);
- Arg_2_Type(TC_FIXNUM);
- Length = Array_Length(Arg1);
- Range_Check(Sampling_Ratio, Arg2, 1, Length, ERR_ARG_2_BAD_RANGE);
-
- Array = Scheme_Array_To_C_Array(Arg1);
- New_Length = Length / Sampling_Ratio;
- / * greater than zero * /
- Allocate_Array(Result, New_Length, allocated_cells);
- To_Here = Scheme_Array_To_C_Array(Result);
-
- for (i=0; i<Length; i += Sampling_Ratio) {
- *To_Here++ = Array[i];
- }
-
- return Result;
-}
-
-\f
-/ * ARRAY-APERIODIC-SHIFT can be done in scheme using subarray, and array-append * /
-
-
-for UPSAMPLING
-if ((Length % Sampling_Ratio) != 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
-UNIMPLEMENTED YET
-
-*/
-
-/* END OF FILE */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/image.h,v 9.21 1987/01/22 14:27:37 jinx Rel $ */
-
-extern Image_Fast_Transpose(); /* REAL *Array; long nrows; OPTIMIZATION for square images */
-extern Image_Transpose(); /* REAL *Array, *New_Array; long nrows, ncols; */
-extern Image_Rotate_90clw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
-extern Image_Rotate_90cclw(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
-extern Image_Mirror(); /* REAL *Array; long nrows, ncols; */
-
-extern Image_Mirror_Upside_Down(); /* Array,nrows,ncols,Temp_Array;
- REAL *Array,*Temp_Row; long nrows, ncols; */
-extern Image_Read_From_CTSCAN_File(); /* FILE *fp; REAL *Array; long nrows, ncols */
-
-extern Image_Rotate_90clw_Mirror(); /* REAL *Array, *Rotated_Array; long nrows, ncols; */
-
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale();
-extern Image_Draw_Magnify_N_Times_With_Offset_Scale_Only();
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.22 1987/04/16 02:24:17 jinx Exp $
- *
- * Single-processor simulation of locking, propagating, and
- * communicating stuff.
- */
-\f
-#include "scheme.h"
-#include "primitive.h"
-#include "locks.h"
-#include "zones.h"
-
-#ifndef COMPILE_FUTURES
-#include "Error: intercom.c is useless without COMPILE_FUTURES"
-#endif
-
-/* (GLOBAL-INTERRUPT LEVEL WORK TEST)
-
- There are 4 global interrupt levels, level 0 (highest priority)
- being reserved for GC. See const.h for details of the dist-
- ribution of these bits with respect to local interrupt levels.
-
- Force all other processors to begin executing WORK (an interrupt
- handler [procedure of two arguments]) provided that TEST returns
- true. TEST is supplied to allow this primitive to be restarted if it
- is unable to begin because another processor wins the race to
- generate a global interrupt and makes it no longer necessary that
- this processor generate one (TEST receives no arguments). This
- primitive returns the value of the call to TEST (i.e. non-#!FALSE if
- the interrupt was really generated), and returns only after all other
- processors have begun execution of WORK (or TEST returns false).
-*/
-\f
-Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT")
-{
- long Saved_Zone, Which_Level;
-
- Primitive_3_Args();
- Arg_1_Type(TC_FIXNUM);
- Range_Check(Which_Level, Arg1, 0, 3, ERR_ARG_1_BAD_RANGE);
- Save_Time_Zone(Zone_Global_Int);
- Pop_Primitive_Frame(3);
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Store_Return(RC_FINISH_GLOBAL_INT);
- Store_Expression(Arg1);
- Save_Cont();
- Push(Arg3);
- Push(STACK_FRAME_HEADER);
- Pushed();
- Restore_Time_Zone();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /*NOTREACHED*/
-}
-
-Pointer
-Global_Int_Part_2(Which_Level, Do_It)
- Pointer Do_It, Which_Level;
-{
- return Do_It;
-}
-\f
-Define_Primitive(Prim_Put_Work, 1, "PUT-WORK")
-{
- Pointer The_Queue, Queue_Tail, New_Entry;
- Primitive_1_Arg();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue == NIL)
- {
- Primitive_GC_If_Needed(4);
- The_Queue = Make_Pointer(TC_LIST, Free);
- Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
- *Free++ = NIL;
- *Free++ = NIL;
- }
- else
- Primitive_GC_If_Needed(2);
- Queue_Tail = Vector_Ref(The_Queue, CONS_CDR);
- New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
- *Free++ = Arg1;
- *Free++ = NIL;
- Vector_Set(The_Queue, CONS_CDR, New_Entry);
- if (Queue_Tail == NIL)
- Vector_Set(The_Queue, CONS_CAR, New_Entry);
- else Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
- return TRUTH;
-}
-
-Define_Primitive(Prim_Drain_Queue, 0, "DRAIN-WORK-QUEUE!")
-{
- Pointer The_Queue;
- Primitive_0_Args();
-
- The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- Set_Fixed_Obj_Slot(The_Work_Queue, NIL);
- return ((The_Queue != NIL) ?
- Vector_Ref(The_Queue, CONS_CAR) :
- NIL);
-}
-\f
-Define_Primitive(Prim_Await_Sync, 1, "AWAIT-SYNCHRONY")
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_LIST);
- if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- return TRUTH;
-}
-
-Define_Primitive(Prim_N_Interps, 0, "N-INTERPRETERS")
-{
- Primitive_0_Args();
-
- return Make_Unsigned_Fixnum(1);
-}
-
-Define_Primitive(Prim_My_Proc, 0, "MY-PROCESSOR-NUMBER")
-{
- Primitive_0_Args();
-
- return Make_Unsigned_Fixnum(0);
-}
-
-Define_Primitive(Prim_My_Interp_Number, 0, "MY-INTERPRETER-NUMBER")
-{
- Primitive_0_Args();
-
- return Make_Unsigned_Fixnum(0);
-}
-
-Define_Primitive(Prim_Zero_Zones, 0, "ZERO-ZONES")
-{
- long i;
- Primitive_0_Args();
-
-#ifdef METERING
- for (i=0; i < Max_Meters; i++)
- Time_Meters[i]=0;
-
- Old_Time=Sys_Clock();
-#endif
- return TRUTH;
-}
-\f
-/* These are really used by GC on a true parallel machine */
-
-Define_Primitive(Prim_GC_Needed, 0, "GC-NEEDED?")
-{
- Primitive_0_Args();
-
- if ((Free+GC_Space_Needed) >= MemTop) return TRUTH;
- else return NIL;
-}
-
-Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC")
-{
- Primitive_0_Args();
-
- return TRUTH;
-}
-
-Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC")
-{
- Primitive_0_Args();
-
- return TRUTH;
-}
-
-Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC")
-{
- Primitive_0_Args();
-
- return TRUTH;
-}
-
-/* This primitive caches the Scheme object for the garbage collector
- primitive so that it does not have to perform an expensive search
- each time.
-*/
-
-Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP")
-{
- static Pointer gc_prim = NIL;
- extern Pointer make_primitive();
- Primitive_1_Arg();
-
- if (gc_prim == NIL)
- {
- gc_prim = make_primitive("GARBAGE-COLLECT");
- }
- Pop_Primitive_Frame(1);
- Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
- Push(Arg1);
- Push(gc_prim);
- Push(STACK_FRAME_HEADER + 1);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.39 1987/04/16 02:01:51 jinx Exp $
-
- Utilities for manipulating symbols.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "trap.h"
-\f
-/* Hashing strings and character lists. */
-
-long
-Do_Hash(String_Ptr, String_Length)
- char *String_Ptr;
- long String_Length;
-{
- long i, Value, End_Count;
-
- Value = (LENGTH_MULTIPLIER * String_Length);
- End_Count = ((String_Length > MAX_HASH_CHARS) ?
- MAX_HASH_CHARS :
- String_Length);
- for (i = 0; i < End_Count; i++)
- Value = ((Value << SHIFT_AMOUNT) + (MAX_CHAR & String_Ptr[i]));
- return Value;
-}
-
-Pointer Hash(Ptr)
- Pointer Ptr;
-{
- long String_Length;
-
- String_Length = Get_Integer(Fast_Vector_Ref(Ptr, STRING_LENGTH));
- return Make_Non_Pointer(TC_FIXNUM,
- Do_Hash(Scheme_String_To_C_String(Ptr),
- String_Length));
-}
-
-Boolean
-string_equal(String1, String2)
- Pointer String1, String2;
-{
- fast char *S1, *S2;
- fast long i, Length1, Length2;
-
- if (Address(String1) == Address(String2))
- return true;
- Length1 = Get_Integer(Fast_Vector_Ref(String1, STRING_LENGTH));
- Length2 = Get_Integer(Fast_Vector_Ref(String2, STRING_LENGTH));
- if (Length1 != Length2)
- return false;
-
- S1 = ((char *) Nth_Vector_Loc(String1, STRING_CHARS));
- S2 = ((char *) Nth_Vector_Loc(String2, STRING_CHARS));
- for (i = 0; i < Length1; i++)
- if (*S1++ != *S2++)
- return false;
- return true;
-}
-\f
-/* Interning involves hashing the input string and either returning
- an existing symbol with that name from the ObArray or creating a
- new symbol and installing it in the ObArray. The resulting interned
- symbol is stored in *Un_Interned.
-*/
-
-extern void Intern();
-
-void
-Intern(Un_Interned)
- Pointer *Un_Interned;
-{
- long Hashed_Value;
- Pointer Ob_Array, *Bucket, String, Temp;
-
- String = Fast_Vector_Ref(*Un_Interned, SYMBOL_NAME);
- Temp = Hash(String);
- Hashed_Value = Get_Integer(Temp);
- Ob_Array = Get_Fixed_Obj_Slot(OBArray);
- Hashed_Value %= Vector_Length(Ob_Array);
- Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value + 1);
-
- while (*Bucket != NIL)
- {
- if (string_equal(String,
- Fast_Vector_Ref(
- Vector_Ref(*Bucket, CONS_CAR),
- SYMBOL_NAME)))
- {
- *Un_Interned = Vector_Ref(*Bucket, CONS_CAR);
- return;
- }
- Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
- }
-
-/* Symbol does not exist yet in obarray. Bucket points to the
- cell containing the final #!NULL in the list. Replace this
- with the CONS of the new symbol and #!NULL (i.e. extend the
- list in the bucket by 1 new element).
-*/
-
- Store_Type_Code(*Un_Interned, TC_INTERNED_SYMBOL);
- *Bucket = Make_Pointer(TC_LIST, Free);
- Free[CONS_CAR] = *Un_Interned;
- Free[CONS_CDR] = NIL;
- Free += 2;
- return;
-}
-\f
-Pointer
-string_to_symbol(String)
- Pointer String;
-{
- Pointer New_Symbol, Interned_Symbol, *Orig_Free;
-
- Orig_Free = Free;
- New_Symbol = Make_Pointer(TC_UNINTERNED_SYMBOL, Free);
- Free[SYMBOL_NAME] = String;
- Free[SYMBOL_GLOBAL_VALUE] = UNBOUND_OBJECT;
- Free += 2;
- Interned_Symbol = New_Symbol;
-
- /* The work is done by Intern which returns in Interned_Symbol
- either the same symbol we gave it (in which case we need to check
- for GC) or an existing symbol (in which case we have to release
- the heap space acquired to hold New_Symbol).
- */
-
- Intern(&Interned_Symbol);
- if (Address(Interned_Symbol) == Address(New_Symbol))
- {
- Primitive_GC_If_Needed(0);
- }
- else
- Free = Orig_Free;
- return Interned_Symbol;
-}
-\f
-/* For debugging, given a String, return either a "not interned"
- * message or the address of the symbol and its global value.
- */
-
-void
-Find_Symbol(Scheme_String)
- Pointer Scheme_String;
-{
- Pointer Ob_Array, The_Symbol, *Bucket;
- char *String, *Temp_String;
- long i, Hashed_Value;
-
- String = Scheme_String_To_C_String(Scheme_String);
- for (Temp_String = String, i = 0; *Temp_String == '\0'; i++)
- Temp_String++;
- Hashed_Value = Do_Hash(String, i);
- Ob_Array = Get_Fixed_Obj_Slot(OBArray);
- Hashed_Value %= Vector_Length(Ob_Array);
- Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value);
- while (*Bucket != NIL)
- {
- if (string_equal(Scheme_String,
- Vector_Ref(Vector_Ref(*Bucket, CONS_CAR),
- SYMBOL_NAME)))
- {
- The_Symbol = Vector_Ref(*Bucket, CONS_CAR);
- printf("\nInterned Symbol: 0x%x", The_Symbol);
- Print_Expression(Vector_Ref(The_Symbol, SYMBOL_GLOBAL_VALUE),
- "Value");
- printf("\n");
- return;
- }
- Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
- }
- printf("\nNot interned.\n");
-}
-\f
-/* (STRING->SYMBOL STRING)
- Similar to INTERN-CHARACTER-LIST, except this one takes a string
- instead of a list of ascii values as argument.
- */
-Built_In_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL", 0x7)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_CHARACTER_STRING);
- return string_to_symbol(Arg1);
-}
-
-/* (INTERN-CHARACTER-LIST LIST)
- LIST should consist of the ASCII codes for characters. Returns
- a new (interned) symbol made out of these characters. Notice
- that this is a fairly low-level primitive, and no checking is
- done on the characters except that they are in the range 0 to
- 255. Thus non-printing, lower-case, and special characters can
- be put into symbols this way.
-*/
-
-Built_In_Primitive(Prim_Intern_Character_List, 1,
- "INTERN-CHARACTER-LIST", 0xAB)
-{
- extern Pointer list_to_string();
- Primitive_1_Arg();
-
- return string_to_symbol(list_to_string(Arg1));
-}
-\f
-/* (STRING-HASH STRING)
- Return a hash value for a string. This uses the hashing
- algorithm used for interning symbols. It is intended for use by
- the reader in creating interned symbols.
-*/
-Built_In_Primitive(Prim_String_Hash, 1, "STRING-HASH", 0x83)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_CHARACTER_STRING);
- return Hash(Arg1);
-}
-
-/* (CHARACTER-LIST-HASH LIST)
- Takes a list of ASCII codes for characters and returns a hash
- code for them. This uses the hashing function used to intern
- symbols in Fasload, and is really intended only for that
- purpose.
-*/
-Built_In_Primitive(Prim_Character_List_Hash, 1,
- "CHARACTER-LIST-HASH", 0x65)
-{
- long Length;
- Pointer This_Char;
- char String[MAX_HASH_CHARS];
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- for (Length = 0; Type_Code(Arg1) == TC_LIST; Length++)
- {
- if (Length < MAX_HASH_CHARS)
- {
- Touch_In_Primitive(Vector_Ref(Arg1, CONS_CAR), This_Char);
- if (Type_Code(This_Char) != TC_CHARACTER)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Range_Check(String[Length], This_Char,
- '\0', ((char) MAX_CHAR),
- ERR_ARG_1_WRONG_TYPE);
- Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1);
- }
- }
- if (Arg1 != NIL)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return
- Make_Non_Pointer(TC_FIXNUM, Do_Hash(String, Length));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $
- *
- * This file contains the heart of the Scheme Scode
- * interpreter
- *
- */
-
-#define In_Main_Interpreter true
-#include "scheme.h"
-#include "locks.h"
-#include "trap.h"
-#include "lookup.h"
-#include "zones.h"
-\f
-/* In order to make the interpreter tail recursive (i.e.
- * to avoid calling procedures and thus saving unnecessary
- * state information), the main body of the interpreter
- * is coded in a continuation passing style.
- *
- * Basically, this is done by dispatching on the type code
- * for an Scode item. At each dispatch, some processing
- * is done which may include setting the return address
- * register, saving the current continuation (return address
- * and current expression) and jumping to the start of
- * the interpreter.
- *
- * It may be helpful to think of this program as being what
- * you would get if you wrote the straightforward Scheme
- * interpreter and then converted it into continuation
- * passing style as follows. At every point where you would
- * call EVAL to handle a sub-form, you put a jump back to
- * Do_Expression. Now, if there was code after the call to
- * EVAL you first push a "return code" (using Save_Cont) on
- * the stack and move the code that used to be after the
- * call down into the part of this file after the tag
- * Pop_Return.
- *
- * Notice that because of the caller saves convention used
- * here, all of the registers which are of interest have
- * been SAVEd on the racks by the time interpretation arrives
- * at Do_Expression (the top of EVAL).
- *
- * For notes on error handling and interrupts, see the file
- * utils.c.
- *
- * This file is divided into two parts. The first
- * corresponds is called the EVAL dispatch, and is ordered
- * alphabetically by the SCode item handled. The second,
- * called the return dispatch, begins at Pop_Return and is
- * ordered alphabetically by return code name.
- */
-\f
-#define Interrupt(Masked_Code) \
-{ \
- Export_Registers(); \
- Setup_Interrupt(Masked_Code); \
- Import_Registers(); \
- goto Perform_Application; \
-}
-
-#define Immediate_GC(N) \
-{ \
- Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
-}
-
-#define Prepare_Eval_Repeat() \
-{ \
- Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
- Store_Return(RC_EVAL_ERROR); \
- Save_Cont(); \
- Pushed(); \
-}
-
-#define Eval_GC_Check(Amount) \
-if (GC_Check(Amount)) \
-{ \
- Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
-}
-
-#define Eval_Error(Err) \
-{ \
- Export_Registers(); \
- Do_Micro_Error(Err, false); \
- Import_Registers(); \
- goto Internal_Apply; \
-}
-
-#define Pop_Return_Error(Err) \
-{ \
- Export_Registers(); \
- Do_Micro_Error(Err, true); \
- Import_Registers(); \
- goto Internal_Apply; \
-}
-
-#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
-{ \
- Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Contents_of_Val); \
- Save_Cont(); \
-}
-\f
-#define Reduces_To(Expr) \
- { Store_Expression(Expr); \
- New_Reduction(Fetch_Expression(), Fetch_Env()); \
- goto Do_Expression; \
- }
-
-#define Reduces_To_Nth(N) \
- Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
-
-#define Do_Nth_Then(Return_Code, N, Extra) \
- { Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
- New_Subproblem(Fetch_Expression(), Fetch_Env()); \
- Extra; \
- goto Do_Expression; \
- }
-
-#define Do_Another_Then(Return_Code, N) \
- { Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
- Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
- goto Do_Expression; \
- }
-
-#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-
-#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
-#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
-\f
- /***********************/
- /* Macros for Stepping */
- /***********************/
-
-#define Fetch_Trapper(field) \
- Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
-
-#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
-#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
-#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
-\f
-/* Macros for handling FUTUREs */
-
-#ifdef COMPILE_FUTURES
-
-/* Arg_Type_Error handles the error returns from primitives which type check
- their arguments and restarts them or suspends if the argument is a future. */
-
-#define Arg_Type_Error(Arg_No, Err_No) \
-{ \
- fast Pointer *Arg, Orig_Arg; \
- \
- Arg = &(Stack_Ref(Arg_No-1)); \
- Orig_Arg = *Arg; \
- \
- if (Type_Code(*Arg) != TC_FUTURE) \
- Pop_Return_Error(Err_No); \
- \
- while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
- { \
- if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
- *Arg = Future_Value(*Arg); \
- } \
- if (Type_Code(*Arg) != TC_FUTURE) \
- goto Prim_No_Trap_Apply; \
- \
- Save_Cont(); \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
- Push(*Arg); /* Arg 1: The future itself */ \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- *Arg = Orig_Arg; \
- goto Apply_Non_Trapping; \
-}
-\f
-/* Apply_Future_Check is called at apply time to guarantee that certain
- objects (the procedure itself, and its LAMBDA components for user defined
- procedures) are not futures
-*/
-
-#define Apply_Future_Check(Name, Object) \
-{ \
- fast Pointer *Arg, Orig_Answer; \
- \
- Arg = &(Object); \
- Orig_Answer = *Arg; \
- \
- while (Type_Code(*Arg) == TC_FUTURE) \
- { \
- if (Future_Has_Value(*Arg)) \
- { \
- if (Future_Is_Keep_Slot(*Arg)) \
- Log_Touch_Of_Future(*Arg); \
- *Arg = Future_Value(*Arg); \
- } \
- else \
- { \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
- Save_Cont(); \
- Push(*Arg); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- *Arg = Orig_Answer; \
- goto Internal_Apply; \
- } \
- } \
- Name = *Arg; \
-}
-
-/* Future handling macros continue on the next page */
-\f
-/* Future handling macros, continued */
-
-/* Pop_Return_Val_Check suspends the process if the value calculated by
- a recursive call to EVAL is an undetermined future */
-
-#define Pop_Return_Val_Check() \
-{ \
- fast Pointer Orig_Val = Val; \
- \
- while (Type_Code(Val) == TC_FUTURE) \
- { \
- if (Future_Has_Value(Val)) \
- { \
- if (Future_Is_Keep_Slot(Val)) \
- Log_Touch_Of_Future(Val); \
- Val = Future_Value(Val); \
- } \
- else \
- { \
- Save_Cont(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Orig_Val); \
- Save_Cont(); \
- Push(Val); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- goto Internal_Apply; \
- } \
- } \
-}
-
-#else /* Not compiling FUTURES code */
-
-#define Pop_Return_Val_Check()
-#define Apply_Future_Check(Name, Object) Name = (Object)
-#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
-
-#endif
-\f
-/* The EVAL/APPLY ying/yang */
-
-void
-Interpret(dumped_p)
- Boolean dumped_p;
-{
- long Which_Way;
- fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
-
- extern long enter_compiled_expression();
- extern long apply_compiled_procedure();
- extern long return_to_compiled_code();
-
- Reg_Block = &Registers[0];
-
- /* Primitives jump back here for errors, requests to
- * evaluate an expression, apply a function, or handle an
- * interrupt request. On errors or interrupts they leave
- * their arguments on the stack, the primitive itself in
- * Expression, and a RESTART_PRIMITIVE continuation in the
- * return register. In the other cases, they have removed
- * their stack frames entirely.
- */
-
- Which_Way = setjmp(*Back_To_Eval);
- Set_Time_Zone(Zone_Working);
- Import_Registers();
- if (Must_Report_References())
- { Save_Cont();
- Will_Push(CONTINUATION_SIZE + 2);
- Push(Val);
- Save_Env();
- Store_Return(RC_REPEAT_DISPATCH);
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
- Save_Cont();
- Pushed();
- Call_Future_Logging();
- }
-\f
-Repeat_Dispatch:
- switch (Which_Way)
- { case PRIM_APPLY: goto Internal_Apply;
- case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
- case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
- case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
- goto Eval_Non_Trapping;
- case 0: if (!dumped_p) break; /* Else fall through */
- case PRIM_POP_RETURN: goto Pop_Return;
- default: Pop_Return_Error(Which_Way);
- case PRIM_INTERRUPT:
- { Save_Cont();
- Interrupt(IntCode & IntEnb);
- }
- case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
- case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
- case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
- }
-\f
-Do_Expression:
-
- if (Eval_Debug)
- { Print_Expression(Fetch_Expression(), "Eval, expression");
- CRLF();
- }
-
-/* The expression register has an Scode item in it which
- * should be evaluated and the result left in Val.
- *
- * A "break" after the code for any operation indicates that
- * all processing for this operation has been completed, and
- * the next step will be to pop a return code off the stack
- * and proceed at Pop_Return. This is sometimes called
- * "executing the continuation" since the return code can be
- * considered the continuation to be performed after the
- * operation.
- *
- * An operation can terminate with a Reduces_To or
- * Reduces_To_Nth macro. This indicates that the value of
- * the current Scode item is the value returned when the
- * new expression is evaluated. Therefore no new
- * continuation is created and processing continues at
- * Do_Expression with the new expression in the expression
- * register.
- *
- * Finally, an operation can terminate with a Do_Nth_Then
- * macro. This indicates that another expression must be
- * evaluated and them some additional processing will be
- * performed before the value of this S-Code item available.
- * Thus a new continuation is created and placed on the
- * stack (using Save_Cont), the new expression is placed in
- * the Expression register, and processing continues at
- * Do_Expression.
- */
-\f
-/* Handling of Eval Trapping.
-
- If we are handling traps and there is an Eval Trap set,
- turn off all trapping and then go to Internal_Apply to call the
- user supplied eval hook with the expression to be evaluated and the
- environment.
-
-*/
-
- if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL))
- { Stop_Trapping();
- Will_Push(4);
- Push(Fetch_Env());
- Push(Fetch_Expression());
- Push(Fetch_Eval_Trapper());
- Push(STACK_FRAME_HEADER+2);
- Pushed();
- goto Apply_Non_Trapping;
- }
-\f
-Eval_Non_Trapping:
- Eval_Ucode_Hook();
- switch (Type_Code(Fetch_Expression()))
- { case TC_BIG_FIXNUM: /* The self evaluating items */
- case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- case TC_CHARACTER:
- case TC_COMPILED_PROCEDURE:
- case TC_COMPLEX:
- case TC_CONTROL_POINT:
- case TC_DELAYED:
- case TC_ENVIRONMENT:
- case TC_EXTENDED_PROCEDURE:
- case TC_FIXNUM:
- case TC_HUNK3:
- case TC_INTERNED_SYMBOL:
- case TC_LIST:
- case TC_NON_MARKED_VECTOR:
- case TC_NULL:
- case TC_PRIMITIVE:
- case TC_PRIMITIVE_EXTERNAL:
- case TC_PROCEDURE:
- case TC_QUAD:
- case TC_UNINTERNED_SYMBOL:
- case TC_TRUE:
- case TC_VECTOR:
- case TC_VECTOR_16B:
- case TC_VECTOR_1B:
- case TC_REFERENCE_TRAP:
- Val = Fetch_Expression(); break;
-
- case TC_ACCESS:
- Will_Push(CONTINUATION_SIZE);
- Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
-
- case TC_ASSIGNMENT:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
-
- case TC_BROKEN_HEART:
- Export_Registers();
- Microcode_Termination(TERM_BROKEN_HEART);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_COMBINATION:
- { long Array_Length = Vector_Length(Fetch_Expression())-1;
- Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
- Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
- Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
- /* The finger: last argument number */
- Pushed();
- if (Array_Length == 0)
- { Push(STACK_FRAME_HEADER); /* Frame size */
- Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
- }
- Save_Env();
- Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
- }
-
- case TC_COMBINATION_1:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
-
- case TC_COMBINATION_2:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
-
- case TC_COMMENT:
- Reduces_To_Nth(COMMENT_EXPRESSION);
-
- case TC_CONDITIONAL:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
-
- case TC_COMPILED_EXPRESSION:
- execute_compiled_setup();
- Store_Expression( (Pointer) Get_Pointer( Fetch_Expression()));
- Export_Registers();
- Which_Way = enter_compiled_expression();
- goto return_from_compiled_code;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_DEFINITION:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
-
- case TC_DELAY:
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_DELAYED, Free);
- Free[THUNK_ENVIRONMENT] = Fetch_Env();
- Free[THUNK_PROCEDURE] =
- Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
- Free += 2;
- break;
-
- case TC_DISJUNCTION:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
-
- case TC_EXTENDED_LAMBDA: /* Close the procedure */
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
- Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
- Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
- Free += 2;
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#ifdef COMPILE_FUTURES
- case TC_FUTURE:
- if (Future_Has_Value(Fetch_Expression()))
- { Pointer Future = Fetch_Expression();
- if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
- Reduces_To_Nth(FUTURE_VALUE);
- }
- Prepare_Eval_Repeat();
- Will_Push(STACK_ENV_EXTRA_SLOTS+2);
- Push(Fetch_Expression()); /* Arg: FUTURE object */
- Push(Get_Fixed_Obj_Slot(System_Scheduler));
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Internal_Apply;
-#endif
-
- case TC_IN_PACKAGE:
- Will_Push(CONTINUATION_SIZE);
- Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
- IN_PACKAGE_ENVIRONMENT, Pushed());
-
- case TC_LAMBDA: /* Close the procedure */
- case TC_LEXPR:
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_PROCEDURE, Free);
- Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
- Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
- Free += 2;
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_PCOMB0:
- /* In case we back out */
- Reserve_Stack_Space(); /* CONTINUATION_SIZE */
- Finished_Eventual_Pushing(); /* of this primitive */
-
-Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
- N_Args_Primitive(Get_Integer(Fetch_Expression())));
- Pushed();
- Stop_Trapping();
- goto Apply_Non_Trapping;
- }
-Prim_No_Trap_Apply:
- {
- fast long primitive_code;
-
- primitive_code = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
- break;
- }
-\f
- case TC_PCOMB1:
- Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
- Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
-
- case TC_PCOMB2:
- Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
-
- case TC_PCOMB3:
- Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
-
- case TC_SCODE_QUOTE:
- Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
- break;
-
- case TC_SEQUENCE_2:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
-
- case TC_SEQUENCE_3:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
-
- case TC_THE_ENVIRONMENT:
- Val = Fetch_Env(); break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_VARIABLE:
- {
- long temp;
-
-#ifndef No_In_Line_Lookup
-
- fast Pointer *cell;
-
- Set_Time_Zone(Zone_Lookup);
- cell = Get_Pointer(Fetch_Expression());
- lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
- Val = *cell;
- if (Type_Code(Val) != TC_REFERENCE_TRAP)
- {
- Set_Time_Zone(Zone_Working);
- goto Pop_Return;
- }
-
- get_trap_kind(temp, Val);
- switch(temp)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- cell = Get_Pointer(Fetch_Expression());
- temp =
- deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell),
- cell);
- goto external_lookup_return;
-
- /* No need to recompile, pass the fake variable. */
- case TRAP_FLUID:
- temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object);
-
- external_lookup_return:
- Import_Val();
- if (temp != PRIM_DONE)
- break;
- Set_Time_Zone(Zone_Working);
- goto Pop_Return;
-
- case TRAP_UNBOUND:
- temp = ERR_UNBOUND_VARIABLE;
- break;
-
- case TRAP_UNASSIGNED:
- temp = ERR_UNASSIGNED_VARIABLE;
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- default:
- temp = ERR_BROKEN_COMPILED_VARIABLE;
- break;
- }
-
-#else No_In_Line_Lookup
-
- Set_Time_Zone(Zone_Lookup);
- temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
- Import_Val();
- if (temp == PRIM_DONE)
- break;
-
-#endif No_In_Line_Lookup
-
- /* Back out of the evaluation. */
-
- Set_Time_Zone(Zone_Working);
-
- if (temp == PRIM_INTERRUPT)
- {
- Prepare_Eval_Repeat();
- Interrupt(IntCode & IntEnb);
- }
-
- Eval_Error(temp);
- }
-
- case TC_RETURN_CODE:
- default: Eval_Error(ERR_UNDEFINED_USER_TYPE);
- };
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-/* Now restore the continuation saved during an earlier part
- * of the EVAL cycle and continue as directed.
- */
-
-Pop_Return:
- Pop_Return_Ucode_Hook();
- Restore_Cont();
- if (Consistency_Check &&
- (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
- { Push(Val); /* For possible stack trace */
- Save_Cont();
- Export_Registers();
- Microcode_Termination(TERM_BAD_STACK);
- }
- if (Eval_Debug)
- { Print_Return("Pop_Return, return code");
- Print_Expression(Val, "Pop_Return, value");
- CRLF();
- };
-
- /* Dispatch on the return code. A BREAK here will cause
- * a "goto Pop_Return" to occur, since this is the most
- * common occurrence.
- */
-
- switch (Get_Integer(Fetch_Return()))
- { case RC_COMB_1_PROCEDURE:
- Restore_Env();
- Push(Val); /* Arg. 1 */
- Push(NIL); /* Operator */
- Push(STACK_FRAME_HEADER+1);
- Finished_Eventual_Pushing();
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
-
- case RC_COMB_2_FIRST_OPERAND:
- Restore_Env();
- Push(Val);
- Save_Env();
- Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_COMB_2_PROCEDURE:
- Restore_Env();
- Push(Val); /* Arg 1, just calculated */
- Push(NIL); /* Function */
- Push(STACK_FRAME_HEADER+2);
- Finished_Eventual_Pushing();
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
-
- case RC_COMB_APPLY_FUNCTION:
- End_Subproblem();
- Stack_Ref(STACK_ENV_FUNCTION) = Val;
- goto Internal_Apply;
-
- case RC_COMB_SAVE_VALUE:
- { long Arg_Number;
-
- Restore_Env();
- Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
- Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
- Stack_Ref(STACK_COMB_FINGER) =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number);
- /* DO NOT count on the type code being NMVector here, since
- the stack parser may create them with NIL here! */
- if (Arg_Number > 0)
- { Save_Env();
- Do_Another_Then(RC_COMB_SAVE_VALUE,
- (COMB_ARG_1_SLOT - 1) + Arg_Number);
- }
- Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#define define_compiler_restart( return_code, entry) \
- case return_code: \
- { extern long entry(); \
- compiled_code_restart(); \
- Export_Registers(); \
- Which_Way = entry(); \
- goto return_from_compiled_code; \
- }
-
- define_compiler_restart( RC_COMP_INTERRUPT_RESTART,
- comp_interrupt_restart)
-
- define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART,
- comp_lexpr_interrupt_restart)
-
- define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART,
- comp_lookup_apply_restart)
-
- define_compiler_restart( RC_COMP_REFERENCE_RESTART,
- comp_reference_restart)
-
- define_compiler_restart( RC_COMP_ACCESS_RESTART,
- comp_access_restart)
-
- define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART,
- comp_unassigned_p_restart)
-
- define_compiler_restart( RC_COMP_UNBOUND_P_RESTART,
- comp_unbound_p_restart)
-
- define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART,
- comp_assignment_restart)
-
- define_compiler_restart( RC_COMP_DEFINITION_RESTART,
- comp_definition_restart)
-
- case RC_REENTER_COMPILED_CODE:
- compiled_code_restart();
- Export_Registers();
- Which_Way = return_to_compiled_code();
- goto return_from_compiled_code;
-\f
- case RC_CONDITIONAL_DECIDE:
- Pop_Return_Val_Check();
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
-
- case RC_DISJUNCTION_DECIDE:
- /* Return predicate if it isn't NIL; else do ALTERNATIVE */
- Pop_Return_Val_Check();
- End_Subproblem();
- Restore_Env();
- if (Val != NIL) goto Pop_Return;
- Reduces_To_Nth(OR_ALTERNATIVE);
-
- case RC_END_OF_COMPUTATION:
- /* Signals bottom of stack */
- Export_Registers();
- Microcode_Termination(TERM_END_OF_COMPUTATION);
-
- case RC_EVAL_ERROR:
- /* Should be called RC_REDO_EVALUATION. */
- Store_Env(Pop());
- Reduces_To(Fetch_Expression());
-
- case RC_EXECUTE_ACCESS_FINISH:
- {
- long Result;
- Pointer value;
-
- Pop_Return_Val_Check();
- value = Val;
-
- if (Environment_P(Val))
- { Result = Symbol_Lex_Ref(value,
- Fast_Vector_Ref(Fetch_Expression(),
- ACCESS_NAME));
- Import_Val();
- if (Result == PRIM_DONE)
- {
- End_Subproblem();
- break;
- }
- if (Result != PRIM_INTERRUPT)
- {
- Val = value;
- Pop_Return_Error(Result);
- }
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
- Interrupt(IntCode & IntEnb);
- }
- Val = value;
- Pop_Return_Error(ERR_BAD_FRAME);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_EXECUTE_ASSIGNMENT_FINISH:
- {
- long temp;
- Pointer value;
- Lock_Handle set_serializer;
-
-#ifndef No_In_Line_Lookup
-
- Pointer bogus_unassigned;
- fast Pointer *cell;
-
- Set_Time_Zone(Zone_Lookup);
- Restore_Env();
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
- setup_lock(set_serializer, cell);
-
- value = Val;
- bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
- if (value == bogus_unassigned)
- value = UNASSIGNED_OBJECT;
-
- if (Type_Code(*cell) != TC_REFERENCE_TRAP)
- {
- Val = *cell;
-
- normal_assignment_done:
- *cell = value;
- remove_lock(set_serializer);
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- get_trap_kind(temp, *cell);
- switch(temp)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- remove_lock(set_serializer);
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- temp =
- deep_assignment_end(deep_lookup(Fetch_Env(),
- cell[VARIABLE_SYMBOL],
- cell),
- cell,
- value,
- false);
- goto external_assignment_return;
-
- case TRAP_UNASSIGNED:
- Val = bogus_unassigned;
- goto normal_assignment_done;
-
- case TRAP_FLUID:
- /* No need to recompile, pass the fake variable. */
- remove_lock(set_serializer);
- temp = deep_assignment_end(lookup_fluid(*cell),
- fake_variable_object,
- value,
- false);
-
- external_assignment_return:
- Import_Val();
- if (temp != PRIM_DONE)
- break;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- goto Pop_Return;
-
- case TRAP_UNBOUND:
- remove_lock(set_serializer);
- temp = ERR_UNBOUND_VARIABLE;
- break;
-
- default:
- remove_lock(set_serializer);
- temp = ERR_BROKEN_COMPILED_VARIABLE;
- break;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#else
-
- Set_Time_Zone(Zone_Lookup);
- Restore_Env();
- temp = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
- value);
- Import_Val();
- if (temp == PRIM_DONE)
- { End_Subproblem();
- Set_Time_Zone(Zone_Working);
- break;
- }
-
-#endif
-
- Set_Time_Zone(Zone_Working);
- Save_Env();
- if (temp != PRIM_INTERRUPT)
- {
- Val = value;
- Pop_Return_Error(temp);
- }
-
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
- value);
- Interrupt(IntCode & IntEnb);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_EXECUTE_DEFINITION_FINISH:
- {
- Pointer value;
- long result;
-
- value = Val;
- Restore_Env();
- Export_Registers();
- result = Local_Set(Fetch_Env(),
- Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
- Val);
- Import_Registers();
- if (result == PRIM_DONE)
- {
- End_Subproblem();
- break;
- }
- Save_Env();
- if (result == PRIM_INTERRUPT)
- {
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
- value);
- Interrupt(IntCode & IntEnb);
- }
- Val = value;
- Pop_Return_Error(result);
- }
-
- case RC_EXECUTE_IN_PACKAGE_CONTINUE:
- Pop_Return_Val_Check();
- if (Environment_P(Val))
- {
- End_Subproblem();
- Store_Env(Val);
- Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
- }
- Pop_Return_Error(ERR_BAD_FRAME);
-\f
-#ifdef COMPILE_FUTURES
- case RC_FINISH_GLOBAL_INT:
- Export_Registers();
- Val = Global_Int_Part_2(Fetch_Expression(), Val);
- Import_Registers_Except_Val();
- break;
-#endif
-
- case RC_GC_CHECK:
- if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
- {
- Export_Registers();
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
- break;
-
- case RC_HALT:
- Export_Registers();
- Microcode_Termination(TERM_TERM_HANDLER);
-\f
- case RC_INTERNAL_APPLY:
-
-Internal_Apply:
-
-/* Branch here to perform a function application.
-
- At this point the top of the stack contains an application frame
- which consists of the following elements (see sdata.h):
- - A header specifying the frame length.
- - A procedure.
- - The actual (evaluated) arguments.
-
- No registers (except the stack pointer) are meaning full at this point.
- Before interrupts or errors are processed, some registers are cleared
- to avoid holding onto garbage if a garbage collection occurs.
-*/
-
-#define Prepare_Apply_Interrupt() \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Save_Cont(); \
-}
-
-#define Apply_Error(N) \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
- Pop_Return_Error(N); \
-}
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {
- long Count;
-
- Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
- Top_Of_Stack() = Fetch_Apply_Trapper();
- Push(STACK_FRAME_HEADER+Count);
- Stop_Trapping();
- }
-
-Apply_Non_Trapping:
-
- if ((IntCode & IntEnb) != 0)
- {
- long Interrupts;
-
- Interrupts = (IntCode & IntEnb);
- Store_Expression(NIL);
- Val = NIL;
- Prepare_Apply_Interrupt();
- Interrupt(Interrupts);
- }
-
-Perform_Application:
-
- Apply_Ucode_Hook();
-
- {
- fast Pointer Function;
-
- Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
-
- switch(Type_Code(Function))
- {
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_PROCEDURE:
- {
- fast long nargs;
-
- nargs = Get_Integer(Pop());
- Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
-
- {
- fast Pointer formals;
-
- Apply_Future_Check(formals,
- Fast_Vector_Ref(Function, LAMBDA_FORMALS));
-
- if ((nargs != Vector_Length(formals)) &&
- ((Type_Code(Function) != TC_LEXPR) ||
- (nargs < Vector_Length(formals))))
- {
- Push(STACK_FRAME_HEADER + nargs - 1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- }
-
- if (Eval_Debug)
- {
- Print_Expression(Make_Unsigned_Fixnum(nargs),
- "APPLY: Number of arguments");
- }
-
- if (GC_Check(nargs + 1))
- {
- Push(STACK_FRAME_HEADER + nargs - 1);
- Prepare_Apply_Interrupt();
- Immediate_GC(nargs + 1);
- }
-
- {
- fast Pointer *scan;
-
- scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
- while(--nargs >= 0)
- *scan++ = Pop();
- Free = scan;
- Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
- }
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_CONTROL_POINT:
- {
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG)
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Val = Stack_Ref(STACK_ENV_FIRST_ARG);
- Our_Throw(false, Function);
- Apply_Stacklet_Backout();
- Our_Throw_Part_2();
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- /*
- After checking the number of arguments, remove the
- frame header since primitives do not expect it.
- */
-
- case TC_PRIMITIVE:
- {
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
- }
-
- case TC_PRIMITIVE_EXTERNAL:
- {
- fast long NArgs, Proc;
-
- Proc = Datum(Function);
- if (Proc > MAX_EXTERNAL_PRIMITIVE)
- {
- Apply_Error(ERR_UNDEFINED_PRIMITIVE);
- }
- NArgs = N_Args_External(Proc);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- (NArgs + (STACK_ENV_FIRST_ARG - 1)))
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
-
-Repeat_External_Primitive:
- /* Reinitialize Proc in case we "goto Repeat_External..." */
- Proc = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Val = Apply_External(Proc);
- Set_Time_Zone(Zone_Working);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_External(Proc));
-
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_EXTENDED_PROCEDURE:
- {
- Pointer lambda;
- long nargs, nparams, formals, params, auxes,
- rest_flag, size;
-
- fast long i;
- fast Pointer *scan;
-
- nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
-
- if (Eval_Debug)
- {
- Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
- "APPLY: Number of arguments");
- }
-
- lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
- Apply_Future_Check(Function,
- Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
- nparams = Vector_Length(Function) - 1;
-
- Apply_Future_Check(Function, Get_Count_Elambda(lambda));
- formals = Elambda_Formals_Count(Function);
- params = Elambda_Opts_Count(Function) + formals;
- rest_flag = Elambda_Rest_Flag(Function);
- auxes = nparams - (params + rest_flag);
-
- if ((nargs < formals) || (!rest_flag && (nargs > params)))
- {
- Push(STACK_FRAME_HEADER + nargs);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
-
- /* size includes the procedure slot, but not the header. */
- size = params + rest_flag + auxes + 1;
- if (GC_Check(size + 1 + ((nargs > params) ?
- (2 * (nargs - params)) :
- 0)))
- {
- Push(STACK_FRAME_HEADER + nargs);
- Prepare_Apply_Interrupt();
- Immediate_GC(size + 1 + ((nargs > params) ?
- (2 * (nargs - params)) :
- 0));
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
-
- if (nargs <= params)
- {
- for (i = (nargs + 1); --i >= 0; )
- *scan++ = Pop();
- for (i = (params - nargs); --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- if (rest_flag)
- *scan++ = NIL;
- for (i = auxes; --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- }
- else
- {
- /* rest_flag must be true. */
- Pointer list;
-
- list = Make_Pointer(TC_LIST, (scan + size));
- for (i = (params + 1); --i >= 0; )
- *scan++ = Pop();
- *scan++ = list;
- for (i = auxes; --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- /* Now scan == Get_Pointer(list) */
- for (i = (nargs - params); --i >= 0; )
- {
- *scan++ = Pop();
- *scan = Make_Pointer(TC_LIST, (scan + 1));
- scan += 1;
- }
- scan[-1] = NIL;
- }
-
- Free = scan;
- Reduces_To(Get_Body_Elambda(lambda));
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_COMPILED_PROCEDURE:
- {
- apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
- Export_Registers();
- Which_Way = apply_compiled_procedure();
-
-return_from_compiled_code:
- Import_Registers();
- switch (Which_Way)
- {
- case PRIM_DONE:
- { compiled_code_done();
- goto Pop_Return;
- }
-
- case PRIM_APPLY:
- { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
- goto Internal_Apply;
- }
-
- case ERR_COMPILED_CODE_ERROR:
- { /* The compiled code is signalling a microcode error. */
- compiled_error_backout();
- /* The Save_Cont is done by Pop_Return_Error. */
- Pop_Return_Error( compiled_code_error_code);
- }
-
- case PRIM_INTERRUPT:
- { compiled_error_backout();
- Save_Cont();
- Interrupt( (IntCode & IntEnb));
- }
-\f
- case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- { apply_compiled_backout();
- Apply_Error( Which_Way);
- }
-
- case ERR_EXECUTE_MANIFEST_VECTOR:
- { /* This error code means that enter_compiled_expression
- was called in a system without compiler support.
- */
- execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
- Fetch_Expression());
- Pop_Return_Error( Which_Way);
- }
-
- case ERR_INAPPLICABLE_OBJECT:
- { /* This error code means that apply_compiled_procedure
- was called in a system without compiler support.
- */
- apply_compiled_backout();
- Apply_Error( Which_Way);
- }
-
- case ERR_INAPPLICABLE_CONTINUATION:
- { /* This error code means that return_to_compiled_code
- or some other compiler continuation was called in a
- system without compiler support.
- */
- Store_Expression(NIL);
- Store_Return(RC_REENTER_COMPILED_CODE);
- Pop_Return_Error(Which_Way);
- }
-
- default: Microcode_Termination( TERM_COMPILER_DEATH);
- }
- }
-
- default:
- Apply_Error(ERR_INAPPLICABLE_OBJECT);
- } /* End of switch in RC_INTERNAL_APPLY */
- } /* End of RC_INTERNAL_APPLY case */
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_MOVE_TO_ADJACENT_POINT:
- /* Expression contains the space in which we are moving */
- { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
- Pointer Thunk, New_Location;
- if (From_Count != 0)
- { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
- Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
- New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
- Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
- if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
- Stack_Pointer = Simulate_Popping(4);
- else Save_Cont();
- }
- else
- { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1;
- fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT);
- fast long i;
- for (i=0; i < To_Count; i++)
- To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
- Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
- New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
- if (To_Count==0)
- Stack_Pointer = Simulate_Popping(4);
- else Save_Cont();
- }
- if (Fetch_Expression() != NIL)
- Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
- else Current_State_Point = New_Location;
- Will_Push(2);
- Push(Thunk);
- Push(STACK_FRAME_HEADER);
- Pushed();
- goto Internal_Apply;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_INVOKE_STACK_THREAD:
- /* Used for WITH_THREADED_STACK primitive */
- Will_Push(3);
- Push(Val); /* Value calculated by thunk */
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Internal_Apply;
-
- case RC_JOIN_STACKLETS:
- Our_Throw(true, Fetch_Expression());
- Join_Stacklet_Backout();
- Our_Throw_Part_2();
- break;
-
- case RC_NORMAL_GC_DONE:
- End_GC_Hook();
- if (GC_Check(GC_Space_Needed))
- { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
- printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_EXIT);
- }
- GC_Space_Needed = 0;
- Val = Fetch_Expression();
- break;
-\f
- case RC_PCOMB1_APPLY:
- End_Subproblem();
- Push(Val); /* Argument value */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
- goto Primitive_Internal_Apply;
-
- case RC_PCOMB2_APPLY:
- End_Subproblem();
- Push(Val); /* Value of arg. 1 */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
- goto Primitive_Internal_Apply;
-
- case RC_PCOMB2_DO_1:
- Restore_Env();
- Push(Val); /* Save value of arg. 2 */
- Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
-
- case RC_PCOMB3_APPLY:
- End_Subproblem();
- Push(Val); /* Save value of arg. 1 */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
- goto Primitive_Internal_Apply;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_PCOMB3_DO_1:
- { Pointer Temp;
- Temp = Pop(); /* Value of arg. 3 */
- Restore_Env();
- Push(Temp); /* Save arg. 3 again */
- Push(Val); /* Save arg. 2 */
- Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
- }
-
- case RC_PCOMB3_DO_2:
- Restore_Then_Save_Env();
- Push(Val); /* Save value of arg. 3 */
- Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
-
- case RC_POP_RETURN_ERROR:
- case RC_RESTORE_VALUE:
- Val = Fetch_Expression();
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_PURIFY_GC_1:
- { Pointer GC_Daemon_Proc, Result;
- Export_Registers();
- Result = Purify_Pass_2(Fetch_Expression());
- Import_Registers();
- if (Result == NIL)
- { /* The object does not fit in Constant space.
- There is no need to run the daemons, and we should let the runtime
- system know what happened.
- */
- Val = NIL;
- break;
- }
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc==NIL)
- { Val = TRUTH;
- break;
- }
- Store_Expression(NIL);
- Store_Return(RC_PURIFY_GC_2);
- Save_Cont();
- Will_Push(2);
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
- Pushed();
- goto Internal_Apply;
- }
-
- case RC_PURIFY_GC_2:
- Val = TRUTH;
- break;
-
- case RC_REPEAT_DISPATCH:
- Sign_Extend(Fetch_Expression(), Which_Way);
- Restore_Env();
- Val = Pop();
- Restore_Cont();
- goto Repeat_Dispatch;
-
- case RC_REPEAT_PRIMITIVE:
- if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
- goto Repeat_External_Primitive;
- else goto Primitive_Internal_Apply;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-/* The following two return codes are both used to restore
- a saved history object. The difference is that the first
- does not copy the history object while the second does.
- In both cases, the Expression register contains the history
- object and the next item to be popped off the stack contains
- the offset back to the previous restore history return code.
-
- ASSUMPTION: History objects are never created using futures.
-*/
-
- case RC_RESTORE_DONT_COPY_HISTORY:
- { Pointer Stacklet;
- Prev_Restore_History_Offset = Get_Integer(Pop());
- Stacklet = Pop();
- History = Get_Pointer(Fetch_Expression());
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = NULL;
- else if (Stacklet == NIL)
- Prev_Restore_History_Stacklet = NULL;
- else
- Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
- break;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_RESTORE_HISTORY:
- { Pointer Stacklet;
- Export_Registers();
- if (! Restore_History(Fetch_Expression()))
- { Import_Registers();
- Save_Cont();
- Will_Push(CONTINUATION_SIZE);
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Pushed();
- Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
- }
- Import_Registers();
- Prev_Restore_History_Offset = Get_Integer(Pop());
- Stacklet = Pop();
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = NULL;
- else
- { if (Stacklet == NIL)
- { Prev_Restore_History_Stacklet = NULL;
- Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
- }
- else
- { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
- Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
- }
- }
- break;
- }
-
- case RC_RESTORE_FLUIDS:
- Fluid_Bindings = Fetch_Expression();
- New_Compiler_MemTop();
- break;
-
- case RC_RESTORE_INT_MASK:
- IntEnb = Get_Integer(Fetch_Expression());
- New_Compiler_MemTop();
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_RESTORE_TO_STATE_POINT:
- { Pointer Where_To_Go = Fetch_Expression();
- Will_Push(CONTINUATION_SIZE);
- /* Restore the contents of Val after moving to point */
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Pushed();
- Export_Registers();
- Translate_To_Point(Where_To_Go);
- break; /* We never get here.... */
- }
-
- case RC_RETURN_TRAP_POINT:
- Store_Return(Old_Return_Code);
- Will_Push(CONTINUATION_SIZE+3);
- Save_Cont();
- Return_Hook_Address = NULL;
- Stop_Trapping();
- Push(Val);
- Push(Fetch_Return_Trapper());
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Apply_Non_Trapping;
-
- case RC_SEQ_2_DO_2:
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth(SEQUENCE_2);
-
- case RC_SEQ_3_DO_2:
- Restore_Then_Save_Env();
- Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
-
- case RC_SEQ_3_DO_3:
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth(SEQUENCE_3);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_SNAP_NEED_THUNK:
- Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH);
- Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
- break;
-
- case RC_AFTER_MEMORY_UPDATE:
- case RC_BAD_INTERRUPT_CONTINUE:
- case RC_COMPLETE_GC_DONE:
- case RC_RESTARTABLE_EXIT:
- case RC_RESTART_EXECUTION:
- case RC_RESTORE_CONTINUATION:
- case RC_RESTORE_STEPPER:
- case RC_POP_FROM_COMPILED_CODE:
- Export_Registers();
- Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
-
- default:
- Export_Registers();
- Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
- };
- goto Pop_Return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.23 1987/04/16 02:25:05 jinx Rel $
- *
- * Macros used by the interpreter and some utilities.
- *
- */
-\f
- /********************/
- /* OPEN CODED RACKS */
- /********************/
-
-/* Move from register to static storage and back */
-
-/* Note defined() cannot be used because VMS does not understand it. */
-
-#ifdef In_Main_Interpreter
-#ifndef ENABLE_DEBUGGING_TOOLS
-#define Cache_Registers
-#endif
-#endif
-
-#ifdef Cache_Registers
-
-#define Regs Reg_Block
-#define Stack_Pointer Reg_Stack_Pointer
-#define History Reg_History
-
-#define Import_Registers() \
-{ \
- Reg_Stack_Pointer = Ext_Stack_Pointer; \
- Reg_History = Ext_History; \
-}
-
-#define Export_Registers() \
-{ \
- Ext_History = Reg_History; \
- Ext_Stack_Pointer = Reg_Stack_Pointer; \
-}
-
-#else
-
-#define Regs Registers
-#define Stack_Pointer Ext_Stack_Pointer
-#define History Ext_History
-
-#define Import_Registers()
-#define Export_Registers()
-
-#endif
-
-#define Import_Val()
-#define Import_Registers_Except_Val() Import_Registers()
-
-#define Import_Regs_After_Primitive()
-#define Export_Regs_Before_Primitive() Export_Registers()
-
-#define Env Regs[REGBLOCK_ENV]
-#define Val Regs[REGBLOCK_VAL]
-#define Expression Regs[REGBLOCK_EXPR]
-#define Return Regs[REGBLOCK_RETURN]
-\f
-/* Internal_Will_Push is in stack.h. */
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Will_Push(N) \
-{ Pointer *Will_Push_Limit; \
- Internal_Will_Push((N)); \
- Will_Push_Limit = Simulate_Pushing(N)
-
-#define Pushed() \
- if (Stack_Pointer < Will_Push_Limit) Stack_Death(); \
-}
-
-#else
-#define Will_Push(N) Internal_Will_Push(N)
-#define Pushed() /* No op */
-#endif
-
-#define Will_Eventually_Push(N) Internal_Will_Push(N)
-#define Finished_Eventual_Pushing() /* No op */
-
-/* Primitive stack operations:
- * These operations hide the direction of stack growth.
- * Throw in stack.h, Allocate_New_Stacklet in utils.c, apply, cwcc and
- * friends in hooks.c, and possibly other stuff, depend on the direction in
- * which the stack grows.
- */
-
-#define Push(P) *--Stack_Pointer = (P)
-#define Pop() (*Stack_Pointer++)
-#define Stack_Ref(N) (Stack_Pointer[(N)])
-#define Simulate_Pushing(N) (Stack_Pointer - (N))
-#define Simulate_Popping(N) (Stack_Pointer + (N))
-
-#define Top_Of_Stack() Stack_Ref(0)
-#define Stack_Distance(previous_top_of_stack) \
- ((previous_top_of_stack) - (&Top_Of_Stack()))
-
-/* These can be used when SP is a pointer into the stack, to make
- * stack gap operations independent of the direction of stack growth.
- * They must match Push and Pop above.
- */
-
-#define Push_From(SP) *--(SP)
-#define Pop_Into(SP, What) (*(SP)++) = (What)
-\f
-/* Stack Gap Operations: */
-
-/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the
- * top of the stack. Code must push Gap_Size objects. It executes Code
- * with the stack pointer placed so that these objects will fill the gap.
- */
-
-#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
-{ Pointer *Saved_Destination; \
- fast Pointer *Destination; \
- fast long size_to_move = (Gap_Position); \
- Destination = Simulate_Pushing(Gap_Size); \
- Saved_Destination = Destination; \
- while (--size_to_move >= 0) \
- Pop_Into(Destination, Pop()); \
- Code; \
- Stack_Pointer = Saved_Destination; \
-}
-
-/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the
- * top of the stack. The contents of the gap are lost.
- */
-
-#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \
-{ fast long size_to_move = (Gap_Position); \
- fast Pointer *Source = Simulate_Popping(size_to_move); \
- Stack_Pointer = Simulate_Popping((Gap_Size) + size_to_move); \
- extra_code; \
- while (--size_to_move >= 0) \
- Push(Push_From(Source)); \
-}
-
-/* Racks operations continue on the next page */
-\f
-/* Rack operations, continued */
-
-/* Fetch from register */
-
-#define Fetch_Expression() Expression
-#define Fetch_Env() Env
-#define Fetch_Return() Return
-
-/* Store into register */
-
-#define Store_Expression(P) Expression = (P)
-#define Store_Env(P) Env = (P)
-#define Store_Return(P) \
- Return = Make_Non_Pointer(TC_RETURN_CODE, (P))
-
-#define Save_Env() Push(Env)
-#define Restore_Env() Env = Pop()
-#define Restore_Then_Save_Env() Env = Top_Of_Stack()
-
-/* Note: Save_Cont must match the definitions in sdata.h */
-
-#define Save_Cont() { Push(Expression); \
- Push(Return); \
- Cont_Print(); \
- }
-
-#define Restore_Cont() { Return = Pop(); \
- Expression = Pop(); \
- if (Cont_Debug) \
- { Print_Return(RESTORE_CONT_RETURN_MESSAGE); \
- Print_Expression(Fetch_Expression(), \
- RESTORE_CONT_EXPR_MESSAGE);\
- CRLF(); \
- } \
- }
-
-#define Cont_Print() if (Cont_Debug) \
- { Print_Return(CONT_PRINT_RETURN_MESSAGE); \
- Print_Expression(Fetch_Expression(), \
- CONT_PRINT_EXPR_MESSAGE); \
- CRLF(); \
- }
-
-#define Stop_Trapping() \
-{ Trapping = false; \
- if (Return_Hook_Address != NULL) \
- *Return_Hook_Address = Old_Return_Code; \
- Return_Hook_Address = NULL; \
-}
-\f
-/* Primitive utility macros */
-
-#define Internal_Apply_Primitive(primitive_code) \
- ((*(Primitive_Procedure_Table[primitive_code]))())
-
-#define N_Args_Primitive(primitive_code) \
- (Primitive_Arity_Table[primitive_code])
-
-#define Internal_Apply_External(external_code) \
- ((*(External_Procedure_Table[external_code]))())
-
-#define N_Args_External(external_code) \
- (External_Arity_Table[external_code])
-
-#define Apply_External(N) \
- Internal_Apply_External(N)
-
-#define Pop_Primitive_Frame(NArgs) \
- Stack_Pointer = Simulate_Popping(NArgs)
-\f
-/* Compiled code utility macros */
-
-/* Going from interpreted code to compiled code */
-
-/* Tail recursion is handled as follows:
- if the return code is `reenter_compiled_code', it is discarded,
- and the two contiguous interpreter segments on the stack are
- merged.
- */
-
-/* Apply interface:
- calling a compiled procedure with a frame nslots long.
- */
-
-#define apply_compiled_setup(nslots) \
-{ long frame_size = (nslots); \
- if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \
- (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
- { /* Merge compiled code segments on the stack. */ \
- Close_Stack_Gap(CONTINUATION_SIZE, \
- frame_size, \
- { long segment_size = \
- Datum(Stack_Ref(CONTINUATION_EXPRESSION - \
- CONTINUATION_SIZE)); \
- last_return_code = Simulate_Popping(segment_size); \
- }); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
- } \
- else \
- { /* Make a new compiled code segment which includes this frame. */ \
- /* History need not be hacked here. */ \
- With_Stack_Gap(1, \
- frame_size, \
- { last_return_code = &Top_Of_Stack(); \
- Push(return_to_interpreter); \
- }); \
- } \
-}
-\f
-/* Eval interface:
- executing a compiled expression.
- */
-
-#define execute_compiled_setup() \
-{ if (Stack_Ref(CONTINUATION_RETURN_CODE) == \
- (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
- { /* Merge compiled code segments on the stack. */ \
- long segment_size; \
- Restore_Cont(); \
- segment_size = Datum(Fetch_Expression()); \
- last_return_code = Simulate_Popping(segment_size); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
- } \
- else \
- { /* Make a new compiled code segment on the stack. */ \
- /* History need not be hacked here. */ \
- last_return_code = &Top_Of_Stack(); \
- Push(return_to_interpreter); \
- } \
-}
-
-/* Pop return interface:
- Returning to compiled code from the interpreter.
- */
-
-#define compiled_code_restart() \
-{ long segment_size; \
- segment_size = Datum(Fetch_Expression()); \
- last_return_code = Simulate_Popping(segment_size); \
- /* Undo the subproblem rotation. */ \
- Compiler_End_Subproblem(); \
-}
-\f
-/* Going from compiled code to interpreted code */
-
-/* Tail recursion is handled in the following way:
- if the return address is `return_to_interpreter', it is discarded,
- and the two contiguous interpreter segments on the stack are
- merged.
- */
-
-/* Apply interface:
- calling an interpreted procedure (or unsafe primitive)
- with a frame nslots long.
- */
-
-#define compiler_apply_procedure(nslots) \
-{ long frame_size = (nslots); \
- if (Stack_Ref( frame_size) == return_to_interpreter) \
- { \
- Close_Stack_Gap(1, frame_size, {}); \
- /* Set up the current rib. */ \
- Compiler_New_Reduction(); \
- } \
- else \
- { /* Make a new interpreter segment which includes this frame. */ \
- With_Stack_Gap(CONTINUATION_SIZE, \
- frame_size, \
- { long segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
- Store_Return(RC_REENTER_COMPILED_CODE); \
- Save_Cont(); \
- }); \
- /* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem(); \
- } \
-}
-
-/* Pop Return interface:
- returning to the interpreter from compiled code.
- Nothing needs to be done at this time.
- */
-
-#define compiled_code_done()
-\f
-/* Various handlers for backing out of compiled code. */
-
-/* Backing out of apply. */
-
-#define apply_compiled_backout() \
-{ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
- Get_Integer( Stack_Ref( STACK_ENV_HEADER))); \
-}
-
-/* Backing out of eval. */
-
-#define execute_compiled_backout() \
-{ if (Top_Of_Stack() == return_to_interpreter) \
- { \
- Simulate_Popping(1); \
- /* Set up the current rib. */ \
- Compiler_New_Reduction(); \
- } \
- else \
- { long segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
- Store_Return(RC_REENTER_COMPILED_CODE); \
- Save_Cont(); \
- /* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem(); \
- } \
-}
-
-/* Backing out because of special errors or interrupts.
- The microcode has already setup a return code with a NIL.
- No tail recursion in this case.
- ***
- Is the history manipulation correct?
- Does Microcode_Error do something special?
- ***
- */
-
-#define compiled_error_backout() \
-{ long segment_size; \
- Restore_Cont(); \
- segment_size = Stack_Distance(last_return_code); \
- Store_Expression(Make_Unsigned_Fixnum(segment_size)); \
- /* The Store_Return is a NOP, the Save_Cont is done by the code \
- that follows. \
- */ \
- /* Store_Return(Datum(Fetch_Return())); */ \
- /* Save_Cont(); */ \
- Compiler_New_Subproblem(); \
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.23 1987/04/16 02:25:19 jinx Rel $
- *
- * List creation and manipulation primitives.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* (CONS LEFT RIGHT)
- Creates a pair with left component LEFT and right component
- RIGHT.
-*/
-Built_In_Primitive(Prim_Cons, 2, "CONS", 0x20)
-{
- Primitive_2_Args();
-
- Primitive_GC_If_Needed(2);
- *Free++ = Arg1;
- *Free++ = Arg2;
- return Make_Pointer(TC_LIST, Free-2);
-}
-
-/* (CDR PAIR)
- Returns the second element in the pair.
-*/
-Built_In_Primitive(Prim_Cdr, 1, "CDR", 0x22)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_LIST);
- return Vector_Ref(Arg1, CONS_CDR);
-}
-
-/* (CAR PAIR)
- Returns the first element in the pair.
-*/
-Built_In_Primitive(Prim_Car, 1, "CAR", 0x21)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_LIST);
- return Vector_Ref(Arg1, CONS_CAR);
-}
-\f
-/* (GENERAL-CAR-CDR LIST DIRECTIONS)
- DIRECTIONS encodes a string of CAR and CDR operations to be
- performed on LIST as follows:
- 1 = NOP 101 = CDAR
- 10 = CDR 110 = CADR
- 11 = CAR 111 = CAAR
- 100 = CDDR ...
-*/
-Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR", 0x27)
-{
- fast long CAR_CDR_Pattern;
- Primitive_2_Args();
-
- Arg_2_Type(TC_FIXNUM);
- CAR_CDR_Pattern = Get_Integer(Arg2);
- while (CAR_CDR_Pattern > 1)
- {
- Touch_In_Primitive(Arg1, Arg1);
- if (Type_Code(Arg1) != TC_LIST)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Arg1 =
- Vector_Ref(Arg1,
- ((CAR_CDR_Pattern & 1) == 0) ? CONS_CDR : CONS_CAR);
- CAR_CDR_Pattern >>= 1;
- }
- return Arg1;
-}
-\f
-/* (ASSQ ITEM A-LIST)
- Searches the association list A-LIST for ITEM, using EQ? for
- testing equality. Returns NIL if ITEM is not found, or the tail
- of the list whose CAAR is ITEM.
-*/
-Built_In_Primitive(Prim_Assq, 2, "ASSQ", 0x5E)
-{
- Pointer This_Assoc_Pair, Key;
- Primitive_2_Args();
-
- Touch_In_Primitive(Arg1, Arg1);
- Touch_In_Primitive(Arg2, Arg2);
- while (Type_Code(Arg2) == TC_LIST)
- {
- Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), This_Assoc_Pair);
- if (Type_Code(This_Assoc_Pair) != TC_LIST)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Touch_In_Primitive(Vector_Ref(This_Assoc_Pair, CONS_CAR), Key);
- if (Key == Arg1)
- return This_Assoc_Pair;
- Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
- }
- if (Arg2 != NIL)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- return NIL;
-}
-
-/* (LENGTH LIST)
- Returns the number of items in the list.
- LENGTH will loop forever if given a circular structure.
-*/
-Built_In_Primitive(Prim_Length, 1, "LENGTH", 0x5D)
-{
- fast long i;
- Primitive_1_Arg();
-
- i = 0;
- Touch_In_Primitive(Arg1, Arg1);
- while (Type_Code(Arg1) == TC_LIST)
- {
- i += 1;
- Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1);
- }
- if (Arg1 != NIL)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return Make_Unsigned_Fixnum(i);
-}
-\f
-/* (MEMQ ITEM LIST)
- Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
- is not found, or the sublist of LIST whose CAR is ITEM.
-*/
-Built_In_Primitive(Prim_Memq, 2, "MEMQ", 0x1C)
-{
- fast Pointer Key;
- Primitive_2_Args();
-
- Touch_In_Primitive(Arg1, Arg1);
- Touch_In_Primitive(Arg2, Arg2);
- while (Type_Code(Arg2) == TC_LIST)
- {
- Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), Key);
- if (Arg1 == Key)
- return Arg2;
- else
- Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
- }
- if (Arg2 != NIL)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- return NIL;
-}
-
-/* (SET-CAR! PAIR VALUE)
- Stores VALUE in the CAR of PAIR. Returns the previous CAR of PAIR.
-*/
-Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!", 0x23)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_LIST);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
-}
-
-/* (SET-CDR! PAIR VALUE)
- Stores VALUE in the CDR of PAIR. Returns the previous CDR of PAIR.
-*/
-Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!", 0x24)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_LIST);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
-}
-\f
-/* (PAIR? OBJECT)
- Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
- created by CONS). Returns NIL otherwise.
-*/
-Built_In_Primitive(Prim_Pair, 1, "PAIR?", 0x7E)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- if (Type_Code(Arg1) == TC_LIST)
- return TRUTH;
- else
- return NIL;
-}
-
-/* (SYSTEM-PAIR? OBJECT)
- Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
-*/
-Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?", 0x85)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- if (GC_Type_List(Arg1))
- return TRUTH;
- else
- return NIL;
-}
-\f
-/* (SYSTEM-PAIR-CAR GC-PAIR)
- Same as CAR, but for anything of GC type PAIR.
-*/
-Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR", 0x86)
-{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Pair);
- return Vector_Ref(Arg1, CONS_CAR);
-}
-
-/* (SYSTEM-PAIR-CDR GC-PAIR)
- Same as CDR, but for anything of GC type PAIR.
-*/
-Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR", 0x87)
-{
- Primitive_1_Arg();
-
- Arg_1_GC_Type(GC_Pair);
- return Vector_Ref(Arg1, CONS_CDR);
-}
-
-/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2)
- Like CONS, but returns an object with the specified type code
- (not limited to type code LIST).
-*/
-Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS", 0x84)
-{
- long Type;
- Primitive_3_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Range_Check(Type, Arg1, 0, MAX_SAFE_TYPE,
- ERR_ARG_1_BAD_RANGE);
- if (GC_Type_Code(Type) == GC_Pair)
- {
- Primitive_GC_If_Needed(2);
- *Free++ = Arg2;
- *Free++ = Arg3;
- return Make_Pointer(Type, Free-2);
- }
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- /*NOTREACHED*/
-}
-
-\f
-/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR)
- Same as SET-CAR!, but for anything of GC type PAIR.
-*/
-Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!", 0x88)
-{
- Primitive_2_Args();
-
- Arg_1_GC_Type(GC_Pair);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
-}
-
-/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR)
- Same as SET-CDR!, but for anything of GC type PAIR.
-*/
-Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!", 0x89)
-{
- Primitive_2_Args();
-
- Arg_1_GC_Type(GC_Pair);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
-}
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.22 1987/04/16 02:25:31 jinx Exp $
- *
- * This file contains common code for reading internal
- * format binary files.
- *
- */
-\f
-#include "fasl.h"
-
-/* Static storage for some shared variables */
-
-long Heap_Count, Const_Count,
- Version, Sub_Version, Machine_Type, Ext_Prim_Count,
- Heap_Base, Const_Base, Dumped_Object,
- Dumped_Heap_Top, Dumped_Constant_Top, Dumped_Stack_Top;
-Pointer Ext_Prim_Vector;
-Boolean Found_Ext_Prims, Byte_Invert_Fasl_Files;
-
-Boolean
-Read_Header()
-{
- Pointer Buffer[FASL_HEADER_LENGTH];
- Pointer Pointer_Heap_Base, Pointer_Const_Base;
-
- Load_Data(FASL_OLD_LENGTH, (char *) Buffer);
- if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
- return false;
-#ifdef BYTE_INVERSION
- Byte_Invert_Header(Buffer,
- (sizeof(Buffer) / sizeof(Pointer)),
- Buffer[FASL_Offset_Heap_Base],
- Buffer[FASL_Offset_Heap_Count]);
-#endif
- Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]);
- Pointer_Heap_Base = Buffer[FASL_Offset_Heap_Base];
- Heap_Base = Datum(Pointer_Heap_Base);
- Dumped_Object = Datum(Buffer[FASL_Offset_Dumped_Obj]);
- Const_Count = Get_Integer(Buffer[FASL_Offset_Const_Count]);
- Pointer_Const_Base = Buffer[FASL_Offset_Const_Base];
- Const_Base = Datum(Pointer_Const_Base);
- Version = The_Version(Buffer[FASL_Offset_Version]);
- Sub_Version = The_Sub_Version(Buffer[FASL_Offset_Version]);
- Machine_Type = The_Machine_Type(Buffer[FASL_Offset_Version]);
- Dumped_Stack_Top = Get_Integer(Buffer[FASL_Offset_Stack_Top]);
- Dumped_Heap_Top =
- C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count));
- Dumped_Constant_Top =
- C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count));
- Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH),
- ((char *) &(Buffer[FASL_OLD_LENGTH])));
-#ifdef BYTE_INVERSION
- Byte_Invert_Region(((char *) &(Buffer[FASL_OLD_LENGTH])),
- (FASL_HEADER_LENGTH - FASL_OLD_LENGTH));
-#endif
- Ext_Prim_Vector =
- Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
- if (Reloc_or_Load_Debug)
- {
- printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n",
- Heap_Count, Heap_Base, Dumped_Heap_Top);
- printf("C_Count = %d; C_Base = %x, Dumped_C_Top = %x\n",
- Const_Count, Const_Base, Dumped_Constant_Top);
- printf("Dumped_S_Top = %x, Ext_Prim_Vector = 0x%08x\n",
- Dumped_Stack_Top, Ext_Prim_Vector);
- printf("Dumped Object (as read from file) = %x\n", Dumped_Object);
- }
- return true;
-}
-
-#ifdef BYTE_INVERSION
-
-Byte_Invert_Header(Header, Headsize, Test1, Test2)
- long *Header, Headsize, Test1, Test2;
-{
- Byte_Invert_Fasl_Files = false;
-
- if ((Test1 & 0xff) == TC_BROKEN_HEART &&
- (Test2 & 0xff) == TC_BROKEN_HEART &&
- (Type_Code(Test1) != TC_BROKEN_HEART ||
- Type_Code(Test2) != TC_BROKEN_HEART))
- {
- Byte_Invert_Fasl_Files = true;
- Byte_Invert_Region(Header, Headsize);
- }
-}
-
-Byte_Invert_Region(Region, Size)
- long *Region, Size;
-{
- register long word, size;
-
- if (Byte_Invert_Fasl_Files)
- for (size = Size; size > 0; size--, Region++)
- {
- word = (*Region);
- *Region = (((word>>24)&0xff) | ((word>>8)&0xff00) |
- ((word<<8)&0xff0000) | ((word<<24)&0xff000000));
- }
-}
-
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/locks.h,v 9.21 1987/01/22 14:28:42 jinx Rel $
-
- Contains everything needed to lock and unlock parts of
- the heap, pure/constant space and the like.
- It also contains intercommunication stuff as well. */
-
-#define Lock_Handle long * /* Address of lock word */
-#define CONTENTION_DELAY 10 /* For "slow" locks, back off */
-#define Lock_Cell(Cell) NULL /* Start lock */
-#define Unlock_Cell(Cell) /* End lock */
-#define Initialize_Heap_Locks() /* Clear at start up */
-#define Do_Store_No_Lock(To, F) *(To) = F
-#define Sleep(How_Long) { } /* Delay for locks, etc. */
-
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */
-
-/* Macros and declarations for the variable lookup code. */
-
-extern Pointer
- *deep_lookup(),
- *lookup_fluid();
-
-extern long
- deep_lookup_end(),
- deep_assignment_end();
-
-extern Pointer
- unbound_trap_object[],
- uncompiled_trap_object[],
- illegal_trap_object[],
- fake_variable_object[];
-\f
-#define GC_allocate_test(N) GC_Check(N)
-
-#define AUX_LIST_TYPE TC_VECTOR
-
-#define AUX_CHUNK_SIZE 20
-#define AUX_LIST_COUNT ENV_EXTENSION_COUNT
-#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE
-#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
-
-/* Variable compilation types. */
-
-#define LOCAL_REF TC_NULL
-#define GLOBAL_REF TC_UNINTERNED_SYMBOL
-#define FORMAL_REF TC_CHARACTER
-#define AUX_REF TC_FIXNUM
-#define UNCOMPILED_REF TC_TRUE
-
-/* Common constants. */
-
-#ifndef b32
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
-#else
-#define UNCOMPILED_VARIABLE 0x08000000
-#endif
-
-/* Macros for speedy variable reference. */
-
-#if (LOCAL_REF == 0)
-
-#define Lexical_Offset(Ind) ((long) (Ind))
-#define Make_Local_Offset(Ind) ((Pointer) (Ind))
-
-#else
-
-#define Lexical_Offset(Ind) Get_Integer(Ind)
-#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
-
-#endif
-\f
-/* The code below depends on the following. */
-
-/* Done as follows because of VMS. */
-
-#define lookup_inconsistency_p \
- ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
- (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
-
-#if (lookup_inconsistency_p)
-#include "error: lookup.h inconsistency detected."
-#endif
-
-#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
-
-#ifdef PARALLEL_PROCESSOR
-
-#define verify(type_code, variable, code, label) \
-{ \
- variable = code; \
- if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
- type_code) \
- goto label; \
-}
-
-#define verified_offset(variable, code) variable
-
-/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
- not matter, but might on a machine with address mapping.
- */
-
-#define setup_lock(handle, cell) handle = Lock_Cell(cell)
-#define remove_lock(handle) Unlock_Cell(handle)
-
-#else
-
-#define verify(type_code, variable, code, label)
-#define verified_offset(variable, code) code
-#define setup_lock(handle, cell)
-#define remove_lock(ignore)
-
-#endif
-\f
-/* Pointer *cell, env, *hunk; */
-
-#define lookup(cell, env, hunk, label) \
-{ \
- fast Pointer frame; \
- long offset; \
- \
-label: \
- \
- frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
- \
- switch (Type_Code(frame)) \
- { \
- case GLOBAL_REF: \
- /* frame is a pointer to the same symbol. */ \
- cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
- break; \
- \
- case LOCAL_REF: \
- cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
- break; \
- \
- case FORMAL_REF: \
- lookup_formal(cell, env, hunk, label); \
- \
- case AUX_REF: \
- lookup_aux(cell, env, hunk, label); \
- \
- default: \
- /* Done here rather than in a separate case because of \
- peculiarities of the bobcat compiler. \
- */ \
- cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \
- uncompiled_trap_object : \
- illegal_trap_object); \
- break; \
- } \
-}
-\f
-#define lookup_formal(cell, env, hunk, label) \
-{ \
- fast long depth; \
- \
- verify(FORMAL_REF, offset, get_offset(hunk), label); \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- cell = Nth_Vector_Loc(frame, \
- verified_offset(offset, get_offset(hunk))); \
- \
- break; \
-}
-
-#define lookup_aux(cell, env, hunk, label) \
-{ \
- fast long depth; \
- \
- verify(AUX_REF, offset, get_offset(hunk), label); \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (Type_Code(frame) != AUX_LIST_TYPE) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
- break; \
-}
-\f
-#define lookup_primitive_type_test() \
-{ \
- if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
- if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \
- Arg_2_Type(TC_UNINTERNED_SYMBOL); \
-}
-
-#define lookup_primitive_end(Result) \
-{ \
- if (Result == PRIM_DONE) \
- return Val; \
- if (Result == PRIM_INTERRUPT) \
- Primitive_Interrupt(); \
- Primitive_Error(Result); \
-}
-
-#define standard_lookup_primitive(action) \
-{ \
- long Result; \
- \
- lookup_primitive_type_test(); \
- Result = action; \
- lookup_primitive_end(Result); \
- /*NOTREACHED*/ \
-}
-
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.28 1987/04/16 02:26:14 jinx Exp $ */
-
-/* Memory management top level.
-
- The memory management code is spread over 3 files:
- - memmag.c: initialization.
- - gcloop.c: main garbage collector loop.
- - purify.c: constant/pure space hacking.
- There is also a relevant header file, gccode.h.
-
- The object dumper, fasdump, shares properties and code with the
- memory management utilities.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "gccode.h"
-
-/* Imports */
-
-extern Pointer *GCLoop();
-
-/* Exports */
-
-extern void GCFlip(), GC();
-extern void Clear_Memory(), Setup_Memory(), Reset_Memory();
-\f
-/* Memory Allocation, sequential processor:
-
- ------------------------------------------
- | Control Stack || |
- | \/ |
- ------------------------------------------
- | Constant + Pure Space /\ |
- | || |
- ------------------------------------------
- | |
- | Heap Space |
- ------------------------------------------
-
- Each area has a pointer to its starting address and a pointer to the
- next free cell. In addition, there is a pointer to the top of the
- useable area of the heap (the heap is subdivided into two areas for
- the purposes of GC, and this pointer indicates the top of the half
- currently in use).
-
-*/
-\f
-/* Initialize free pointers within areas. Stack_Pointer is
- special: it always points to a cell which is in use. */
-
-void
-Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{
- Heap_Top = Heap_Bottom + Our_Heap_Size;
- Local_Heap_Base = Heap_Bottom;
- Unused_Heap_Top = Heap_Bottom + 2*Our_Heap_Size;
- Set_Mem_Top(Heap_Top - GC_Reserve);
- Free = Heap_Bottom;
- Free_Constant = Constant_Space;
- Set_Pure_Top();
- Initialize_Stack();
- return;
-}
-
-/* This procedure allocates and divides the total memory. */
-
-void
-Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
- int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{
- /* Consistency check 1 */
- if (Our_Heap_Size == 0)
- {
- fprintf(stderr, "Configuration won't hold initial data.\n");
- exit(1);
- }
-
- /* Allocate */
- Highest_Allocated_Address =
- Allocate_Heap_Space(Stack_Allocation_Size(Our_Stack_Size) +
- (2 * Our_Heap_Size) +
- Our_Constant_Size +
- HEAP_BUFFER_SPACE);
-
- /* Consistency check 2 */
- if (Heap == NULL)
- {
- fprintf(stderr, "Not enough memory for this configuration.\n");
- exit(1);
- }
-
- /* Initialize the various global parameters */
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
- Unused_Heap = Heap + Our_Heap_Size;
- Align_Float(Unused_Heap);
- Constant_Space = Heap + 2*Our_Heap_Size;
- Align_Float(Constant_Space);
-
- /* Consistency check 3 */
- if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0)
- {
- fprintf(stderr,
- "Largest address does not fit in datum field of Pointer.\n");
- fprintf(stderr,
- "Allocate less space or re-compile without Heap_In_Low_Memory.\n");
- exit(1);
- }
-
- Heap_Bottom = Heap;
- Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size);
- return;
-}
-
-/* In this version, this does nothing. */
-
-void
-Reset_Memory()
-{
- return;
-}
-\f
-/* Utilities for the garbage collector top level.
- The main garbage collector loop is in gcloop.c
-*/
-
-/* Flip into unused heap */
-
-void
-GCFlip()
-{
- Pointer *Temp;
-
- Temp = Unused_Heap;
- Unused_Heap = Heap_Bottom;
- Heap_Bottom = Temp;
- Temp = Unused_Heap_Top;
- Unused_Heap_Top = Heap_Top;
- Heap_Top = Temp;
- Free = Heap_Bottom;
- Set_Mem_Top(Heap_Top - GC_Reserve);
- Weak_Chain = NIL;
- return;
-}
-\f
-/* Here is the code which "prunes" objects from weak cons cells. See
- the picture in gccode.h for a description of the structure built by
- the GC. This code follows the chain of weak cells (in old space) and
- either updates the new copy's CAR with the relocated version of the
- object, or replaces it with NIL.
-
- Note that this is the only code in the system, besides the inner garbage
- collector, which looks at both old and new space.
-*/
-
-Pointer Weak_Chain;
-
-void
-Fix_Weak_Chain()
-{
- fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
-
- Low_Constant = Constant_Space;
- while (Weak_Chain != NIL)
- {
- Old_Weak_Cell = Get_Pointer(Weak_Chain);
- Scan = Get_Pointer(*Old_Weak_Cell++);
- Weak_Chain = *Old_Weak_Cell;
- Old_Car = *Scan;
- Temp = Make_New_Pointer(Type_Code(Weak_Chain), Old_Car);
- Weak_Chain = Make_New_Pointer(TC_NULL, Weak_Chain);
-
- switch(GC_Type(Temp))
- { case GC_Non_Pointer:
- *Scan = Temp;
- continue;
-
- case GC_Special:
- if (Type_Code(Temp) != TC_REFERENCE_TRAP)
- {
- /* No other special type makes sense here. */
- goto fail;
- }
- if (Datum(Temp) <= TRAP_MAX_IMMEDIATE)
- {
- *Scan = Temp;
- continue;
- }
- /* Otherwise, it is a pointer. Fall through */
-
- /* Normal pointer types, the broken heart is in the first word.
- Note that most special types are treated normally here.
- The BH code updates *Scan if the object has been relocated.
- Otherwise it falls through and we replace it with a full NIL.
- Eliminating this assignment would keep old data (pl. of datum).
- */
- case GC_Cell:
- case GC_Pair:
- case GC_Triple:
- case GC_Quadruple:
- case GC_Vector:
- Old = Get_Pointer(Old_Car);
- if (Old >= Low_Constant)
- {
- *Scan = Temp;
- continue;
- }
- Normal_BH(false, continue);
- *Scan = NIL;
- continue;
-
- case GC_Compiled:
- Old = Get_Pointer(Old_Car);
- if (Old >= Low_Constant)
- {
- *Scan = Temp;
- continue;
- }
- Compiled_BH(false, continue);
- *Scan = NIL;
- continue;
-
- case GC_Undefined:
- default: /* Non Marked Headers and Broken Hearts */
- fail:
- fprintf(stderr,
- "\nFix_Weak_Chain: Bad Object: Type = 0x%02x; Datum = %x\n",
- Type_Code(Temp), Datum(Temp));
- Microcode_Termination(TERM_INVALID_TYPE_CODE);
- }
- }
- return;
-}
-\f
-/* Here is the set up for the full garbage collection:
-
- - First it makes the constant space and stack into one large area
- by "hiding" the gap between them with a non-marked header.
-
- - Then it saves away all the relevant microcode registers into new
- space, making this the root for garbage collection.
-
- - Then it does the actual garbage collection in 4 steps:
- 1) Trace constant space.
- 2) Trace objects pointed out by the root and constant space.
- 3) Trace the precious objects, remembering where consing started.
- 4) Update all weak pointers.
-
- - Finally it restores the microcode registers from the copies in
- new space.
-*/
-\f
-void GC()
-{ Pointer *Root, *Result, *Check_Value,
- The_Precious_Objects, *Root2;
-
- /* Save the microcode registers so that they can be relocated */
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(Check_Value);
-
- Root = Free;
- The_Precious_Objects = Get_Fixed_Obj_Slot(Precious_Objects);
- Set_Fixed_Obj_Slot(Precious_Objects, NIL);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL);
-
- *Free++ = Fixed_Objects;
- *Free++ = Make_Pointer(TC_HUNK3, History);
- *Free++ = Undefined_Externals;
- *Free++ = Get_Current_Stacklet();
- *Free++ = ((Prev_Restore_History_Stacklet == NULL) ?
- NIL :
- Make_Pointer(TC_CONTROL_POINT, Prev_Restore_History_Stacklet));
- *Free++ = Current_State_Point;
- *Free++ = Fluid_Bindings;
-
- /* The 4 step GC */
- Result = GCLoop(Constant_Space, &Free);
- if (Result != Check_Value)
- {
- fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- Result = GCLoop(Root, &Free);
- if (Free != Result)
- {
- fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- Root2 = Free;
- *Free++ = The_Precious_Objects;
- Result = GCLoop(Root2, &Free);
- if (Free != Result)
- {
- fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- Fix_Weak_Chain();
-
- /* Make the microcode registers point to the copies in new-space. */
- Fixed_Objects = *Root++;
- Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
- Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
-
- History = Get_Pointer(*Root++);
- Undefined_Externals = *Root++;
- Set_Current_Stacklet(*Root);
- Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
- if (*Root == NIL)
- {
- Prev_Restore_History_Stacklet = NULL;
- Root += 1;
- }
- else
- Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
- Current_State_Point = *Root++;
- Fluid_Bindings = *Root++;
- Free_Stacklets = NULL;
- return;
-}
-\f
-/* (GARBAGE-COLLECT SLACK)
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by invoking
- the GC daemon if there is one.
-
- This primitive never returns normally. It always escapes into
- the interpreter because some of its cached registers (eg. History)
- have changed.
-*/
-
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
-{
- Pointer GC_Daemon_Proc;
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- if (Free > Heap_Top)
- {
- fprintf(stderr,
- "\nGC has been delayed too long, and you are out of room!\n");
- fprintf(stderr,
- "Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n",
- Free, MemTop, Heap_Top);
- Microcode_Termination(TERM_NO_SPACE);
- }
- GC_Reserve = Get_Integer(Arg1);
- GCFlip();
- GC();
- IntCode &= ~INT_GC;
- if (GC_Check(GC_Space_Needed))
- {
- fprintf(stderr,
- "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
- fprintf(stderr,
- "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_NO_SPACE);
- }
- Pop_Primitive_Frame(1);
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc == NIL)
- {
- Val = Make_Unsigned_Fixnum(MemTop - Free);
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
- /*NOTREACHED*/
- }
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
- Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
- Save_Cont();
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
- /* The following comment is by courtesy of LINT, your friendly sponsor. */
- /*NOTREACHED*/
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/missing.c,v 9.21 1987/01/22 14:29:02 jinx Rel $
- * This file contains utilities potentially missing from the math library
- */
-
-#ifdef DEBUG_MISSING
-#include "config.h"
-#endif
-\f
-static Boolean floating_table_initialized = false;
-static double floating_table[(2*FLONUM_EXPT_SIZE)-1];
-static int exponent_table[(2*FLONUM_EXPT_SIZE)-1];
-
-void initialize_floating_table()
-{ register int index, exponent;
- register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
- register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
- register double x;
- the_table[0] = 1.0;
- int_table[0] = 0;
- for (x = 2.0, index = 1, exponent = 1;
- index < FLONUM_EXPT_SIZE;
- x *= x, index += 1, exponent += exponent)
- { the_table[index] = x;
- int_table[index] = exponent;
- }
- for (x = 0.5, index = -1, exponent = -1;
- index > -FLONUM_EXPT_SIZE;
- x *= x, index -= 1, exponent += exponent)
- { the_table[index] = x;
- int_table[index] = exponent;
- }
- floating_table_initialized = true;
- return;
-}
-
-double frexp(value, eptr)
-double value;
-int *eptr;
-{ register double mant;
- register int exponent, index;
- register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
- register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
-
- if (value == 0.0)
- { *eptr = 0;
- return 0.0;
- }
- if (!floating_table_initialized) initialize_floating_table();
- mant = ((value < 0.0) ? -value : value);
- exponent = 0;
- while (mant < 0.5)
- { for (index = -FLONUM_EXPT_SIZE+1;
- the_table[index] < mant;
- index += 1) ;
- exponent += int_table[index];
- mant /= the_table[index];
- }
- if (mant >= 1.0)
- { while (mant >= 2.0)
- { for (index = FLONUM_EXPT_SIZE-1;
- the_table[index] > mant;
- index -= 1) ;
- exponent += int_table[index];
- mant /= the_table[index];
- }
- mant /= 2.0;
- exponent += 1;
- }
- *eptr = exponent;
- return ((value < 0.0) ? -mant : mant);
-}
-
-double ldexp(value, exponent)
-register double value;
-register int exponent;
-{ register int index;
- register double *the_table = &floating_table[FLONUM_EXPT_SIZE-1];
- register int *int_table = &exponent_table[FLONUM_EXPT_SIZE-1];
-
- if (value == 0.0) return 0.0;
- if (!floating_table_initialized) initialize_floating_table();
- while (exponent > 0)
- { for(index = FLONUM_EXPT_SIZE-1;
- int_table[index] > exponent;
- index -= 1) ;
- exponent -= int_table[index];
- value *= the_table[index];
- }
- while (exponent < 0)
- { for(index = -FLONUM_EXPT_SIZE+1;
- int_table[index] < exponent;
- index += 1) ;
- exponent -= int_table[index];
- value *= the_table[index];
- }
- return value;
-}
-
-\f
-#ifdef DEBUG_MISSING
-
-#include <stdio.h>
-
-main()
-{ double input, output;
- int exponent;
-
- while (true)
- { printf("Number -> ");
- scanf("%F", &input);
- output = frexp(input, &exponent);
- printf("Input = %G; Output = %G; Exponent = %d\n",
- input, output, exponent);
- printf("Result = %G\n", ldexp(output, exponent));
- }
-}
-#endif
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $
- *
- * This file contains the portable fixnum multiplication procedure.
- * Returns NIL if the result does not fit in a fixnum.
- * Note: This has only been tried on machines with long = 32 bits.
- * This file is included in the appropriate os file if needed.
- */
-\f
-#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
-#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
-#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
-#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
-#define ABS(x) (((x) < 0) ? -(x) : (x))
-
-Pointer
-Mul(Arg1, Arg2)
- long Arg1, Arg2;
-{
- long A, B, C;
- fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
- Boolean Sign;
-
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
- Sign = ((A < 0) == (B < 0));
- A = ABS(A);
- B = ABS(B);
- Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
- Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
- Lo_A = (A & HALF_WORD_MASK);
- Lo_B = (B & HALF_WORD_MASK);
- Lo_C = (Lo_A * Lo_B);
- if (Lo_C > FIXNUM_SIGN_BIT)
- return NIL;
- Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
- if (Middle_C >= MAX_MIDDLE)
- return NIL;
- if ((Hi_A > 0) && (Hi_B > 0))
- return NIL;
- C = Lo_C + (Middle_C << HALF_WORD_SIZE);
- if (Fixnum_Fits(C))
- {
- if (Sign || (C == 0))
- return Make_Unsigned_Fixnum(C);
- else
- return Make_Unsigned_Fixnum(MAX_FIXNUM - C);
- }
- return NIL;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */
-
-/* This file contains definitions pertaining to the C view of
- Scheme pointers: widths of fields, extraction macros, pre-computed
- extraction masks, etc. */
-\f
-/* The C type Pointer is defined at the end of CONFIG.H
- The definition of POINTER_LENGTH here assumes that Pointer is the same
- as unsigned long. If that ever changes, this definition must also.
- POINTER_LENGTH is defined this way to make it available to
- the preprocessor. */
-
-#define POINTER_LENGTH ULONG_SIZE
-#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
-#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-
-/* The danger bit is being phased out. It is currently used by stacklets
- and the history mechanism. The variable lookup code no longer uses it.
- */
-
-#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
-#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
-#define SAFE_TYPE_MASK MAX_SAFE_TYPE
-#define DANGER_BIT HIGH_BIT
-
-#ifndef b32 /* Safe versions */
-
-#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
-#define TYPE_CODE_MASK (~ADDRESS_MASK)
-#define HIGH_BIT (1 << (POINTER_LENGTH-1))
-/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
-#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
-#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
-#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
-#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
-
-#else /* 32 bit word versions */
-
-#define ADDRESS_LENGTH 24
-#define ADDRESS_MASK 0x00FFFFFF
-#define TYPE_CODE_MASK 0xFF000000
-#define HIGH_BIT 0x80000000
-#define FIXNUM_LENGTH 23
-#define FIXNUM_SIGN_BIT 0x00800000
-#define SIGN_MASK 0xFF800000
-#define SMALLEST_FIXNUM 0xFF800000
-#define BIGGEST_FIXNUM 0x007FFFFF
-
-#endif
-\f
-#ifndef UNSIGNED_SHIFT /* Safe version */
-#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
-#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK)
-#else /* Faster for logical shifts */
-#define pointer_type(P) ((P) >> ADDRESS_LENGTH)
-#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK)
-#endif
-
-#define pointer_datum(P) ((P) & ADDRESS_MASK)
-
-/* compatibility definitions */
-#define Type_Code(P) (pointer_type (P))
-#define Safe_Type_Code(P) (safe_pointer_type (P))
-#define Datum(P) (pointer_datum (P))
-
-#define Make_Object(TC, D) \
-((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D)))
-\f
-#ifndef Heap_In_Low_Memory /* Safe version */
-
-typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
-
-extern Pointer *Memory_Base;
-
-/* The "-1" in the value returned is a guarantee that there is one
- word reserved exclusively for use by the garbage collector. */
-
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
- ((Memory_Base + (space)) - 1))
-
-#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P))))
-#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base))
-
-#else /* Storing absolute addresses */
-
-typedef long relocation_type; /* Used to relocate pointers on fasload */
-
-#define Allocate_Heap_Space(space) \
- (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- ((Heap + (space)) - 1))
-
-#ifdef spectrum
-
-#define Quad1_Tag 0x40000000
-#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag))
-#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK))
-
-#else /* Not Spectrum, fast case */
-
-#define Get_Pointer(P) ((Pointer *) (pointer_datum (P)))
-#define C_To_Scheme(P) ((Pointer) (P))
-
-#endif /* spectrum */
-#endif /* Heap_In_Low_Memory */
-\f
-#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
-#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
-
-/* (Make_New_Pointer (TC, A)) may be more efficient than
- (Make_Pointer (TC, (Get_Pointer (A)))) */
-
-#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A)))
-
-#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P)))
-
-#define Store_Address(P, A) \
- P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A))))
-
-#define Address(P) (pointer_datum (P))
-
-/* These are used only where the object is known to be immutable.
- On a parallel processor they don't require atomic references */
-
-#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N])
-#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S)
-#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1)
-#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S)
-#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N)))
-#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0)))
-
-/* General case vector handling requires atomicity for parallel processors */
-
-#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N))
-#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S)
-#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
-#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
-\f
-#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
-#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
-#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
-#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
-#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
-#define Get_Integer(P) (pointer_datum (P))
-
-#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0)
-
-#define Sign_Extend(P, S) \
-{ \
- (S) = (Get_Integer (P)); \
- if (((S) & FIXNUM_SIGN_BIT) != 0) \
- (S) |= (-1 << ADDRESS_LENGTH); \
-}
-
-#define Fixnum_Fits(x) \
- ((((x) & SIGN_MASK) == 0) || \
- (((x) & SIGN_MASK) == SIGN_MASK))
-
-/* Playing with the danger bit */
-
-#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT))
-#define Dangerous(P) ((P & DANGER_BIT) != 0)
-#define Clear_Danger_Bit(P) P &= ~DANGER_BIT
-#define Set_Danger_Bit(P) P |= DANGER_BIT
-/* Side effect testing */
-
-#define Is_Constant(address) \
- (((address) >= Constant_Space) && ((address) < Free_Constant))
-
-#define Is_Pure(address) \
- ((Is_Constant (address)) && (Pure_Test (address)))
-
-#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
-if ((Is_Constant (Get_Pointer (Old_Pointer))) && \
- (GC_Type (Will_Contain) != GC_Non_Pointer) && \
- (! (Is_Constant (Get_Pointer (Will_Contain)))) && \
- (Pure_Test (Get_Pointer (Old_Pointer)))) \
- Primitive_Error (ERR_WRITE_INTO_PURE_SPACE);
-\f
-#ifdef FLOATING_ALIGNMENT
-
-#define FLOATING_BUFFER_SPACE \
- ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
-
-#define HEAP_BUFFER_SPACE \
- (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
-
-/* The space is there, find the correct position. */
-
-#define Initial_Align_Float(Where) \
-{ \
- while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- Where -= 1; \
-}
-
-#define Align_Float(Where) \
-{ \
- while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
-}
-
-#else not FLOATING_ALIGNMENT
-
-#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
-
-#define Initial_Align_Float(Where)
-#define Align_Float(Where)
-
-#endif FLOATING_ALIGNMENT
+++ /dev/null
-#ifdef BSD
-#ifndef BSD4_1
-#define HAVE_GETPAGESIZE
-#endif
-#endif
-
-#ifndef HAVE_GETPAGESIZE
-
-#include <sys/param.h>
-
-#ifdef EXEC_PAGESIZE
-#define getpagesize() EXEC_PAGESIZE
-#else
-#ifdef NBPG
-#define getpagesize() NBPG * CLSIZE
-#ifndef CLSIZE
-#define CLSIZE 1
-#endif /* no CLSIZE */
-#else /* no NBPG */
-#define getpagesize() NBPC
-#endif /* no NBPG */
-#endif /* no EXEC_PAGESIZE */
-
-#endif /* not HAVE_GETPAGESIZE */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
- *
- * Dumps Scheme FASL in user-readable form .
- */
-\f
-#include "scheme.h"
-
-/* These are needed by load.c */
-
-static Pointer *Memory_Base;
-
-#define Load_Data(Count,To_Where) \
- fread(To_Where, sizeof(Pointer), Count, stdin)
-
-#define Reloc_or_Load_Debug true
-
-#include "load.c"
-#include "gctype.c"
-
-#ifdef Heap_In_Low_Memory
-#ifdef spectrum
-#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer))
-#else
-#define File_To_Pointer(P) ((P) / sizeof(Pointer))
-#endif /* spectrum */
-#else
-#define File_To_Pointer(P) (P)
-#endif
-
-#ifndef Conditional_Bug
-#define Relocate(P) \
- (((long) (P) < Const_Base) ? \
- File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
-#else
-#define Relocate_Into(What, P)
-if (((long) (P)) < Const_Base)
- (What) = File_To_Pointer(((long) (P)) - Heap_Base);
-else
- (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
-
-static long Relocate_Temp;
-#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
-#endif
-
-static Pointer *Data, *end_of_memory;
-
-Boolean
-scheme_string(From, Quoted)
-long From;
-Boolean Quoted;
-{ fast long i, Count;
- fast char *Chars;
- Chars = (char *) &Data[From+STRING_CHARS];
- if (Chars < ((char *) end_of_memory))
- { Count = Get_Integer(Data[From+STRING_LENGTH]);
- if (&Chars[Count] < ((char *) end_of_memory))
- { putchar(Quoted ? '\"' : '\'');
- for (i=0; i < Count; i++) printf("%c", *Chars++);
- if (Quoted) putchar('\"');
- putchar('\n');
- return true;
- }
- }
- if (Quoted)
- printf("String not in memory; datum = %x\n", From);
- return false;
-}
-
-#define via(File_Address) Relocate(Address(Data[File_Address]))
-
-void
-scheme_symbol(From)
-long From;
-{ Pointer *symbol;
- symbol = &Data[From+SYMBOL_NAME];
- if ((symbol >= end_of_memory) ||
- !scheme_string(via(From+SYMBOL_NAME), false))
- printf("symbol not in memory; datum = %x\n", From);
- return;
-}
-\f
-Display(Location, Type, The_Datum)
-long Location, Type, The_Datum;
-{ long Points_To;
- printf("%5x: %2x|%6x ", Location, Type, The_Datum);
- if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
- Points_To = Relocate((Pointer *) The_Datum);
- else
- Points_To = The_Datum;
- if (Type > MAX_SAFE_TYPE) printf("*");
- switch (Type & SAFE_TYPE_MASK)
- { /* "Strange" cases */
- case TC_NULL: if (The_Datum == 0)
- { printf("NIL\n");
- return;
- }
- else printf("[NULL ");
- break;
- case TC_TRUE: if (The_Datum == 0)
- { printf("TRUE\n");
- return;
- }
- else printf("[TRUE ");
- break;
- case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
- if (The_Datum == 0)
- Points_To = 0;
- break;
- case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
- Points_To = The_Datum;
- break;
- case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
- Points_To = The_Datum;
- break;
- case TC_INTERNED_SYMBOL: scheme_symbol(Points_To);
- return;
- case TC_UNINTERNED_SYMBOL:
- printf("uninterned ");
- scheme_symbol(Points_To);
- return;
- case TC_CHARACTER_STRING: scheme_string(Points_To, true);
- return;
- case TC_FIXNUM: printf("%d\n", Points_To);
- return;
-
- /* Default cases */
- case TC_LIST: printf("[LIST "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
- case TC_PCOMB2: printf("[PCOMB2 "); break;
- case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
- case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
- case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
- case TC_DELAY: printf("[DELAY "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
- case TC_COMMENT: printf("[COMMENT "); break;
- case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
- case TC_LAMBDA: printf("[LAMBDA "); break;
- case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
- case TC_PCOMB1: printf("[PCOMB1 "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_ACCESS: printf("[ACCESS "); break;
- case TC_DEFINITION: printf("[DEFINITION "); break;
- case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
- case TC_HUNK3: printf("[HUNK3 "); break;
- case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
- case TC_LEXPR: printf("[LEXPR "); break;
- case TC_PCOMB3: printf("[PCOMB3 "); break;
-
- case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB0 "); break;
- case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_CELL: printf("[CELL "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
- case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
- case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
- case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
- case TC_COMPLEX: printf("[COMPLEX "); break;
- case TC_QUAD: printf("[QUAD "); break;
- default: printf("[02x%x ", Type); break;
- }
- printf("%x]\n", Points_To);
-}
-
-main(argc, argv)
-int argc;
-char **argv;
-{ Pointer *Next;
- long i;
- if (argc == 1)
- { if (!Read_Header())
- { fprintf(stderr, "Input does not appear to be in FASL format.\n");
- exit(1);
- }
- printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
- if (Sub_Version >= FASL_LONG_HEADER)
- printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
- }
- else
- { Const_Count = 0;
- sscanf(argv[1], "%x", &Heap_Base);
- sscanf(argv[2], "%x", &Const_Base);
- sscanf(argv[3], "%d", &Heap_Count);
- printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
- Heap_Base, Const_Base, Heap_Count);
- }
- Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
- end_of_memory = &Data[Heap_Count + Const_Count];
- Load_Data(Heap_Count + Const_Count, Data);
- printf("Heap contents\n\n");
- for (Next=Data, i=0; i < Heap_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
- Display(i, Type_Code(*Next), Address(*Next));
- Next += 1;
- for (j=0; j < count ; j++, Next++)
- printf(" %02x%06x\n",
- Type_Code(*Next), Address(*Next));
- i += count;
- Next -= 1;
- }
- else Display(i, Type_Code(*Next), Address(*Next));
- printf("\n\nConstant space\n\n");
- for (; i < Heap_Count+Const_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
- Display(i, Type_Code(*Next), Address(*Next));
- Next += 1;
- for (j=0; j < count ; j++, Next++)
- printf(" %02x%06x\n",
- Type_Code(*Next), Address(*Next));
- i += count;
- Next -= 1;
- }
- else Display(i, Type_Code(*Next), Address(*Next));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.25 1987/04/16 23:20:46 jinx Rel $
- *
- * The leftovers ... primitives that don't seem to belong elsewhere.
- *
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* Random predicates: */
-
-/* (NULL? OBJECT)
- Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is
- the primitive known as NOT, NIL?, and NULL? in Scheme.
-*/
-Built_In_Primitive(Prim_Null, 1, "NULL?", 0xC)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- return (Arg1 == NIL) ? TRUTH : NIL;
-}
-
-/* (EQ? OBJECT-1 OBJECT-2)
- Returns #!TRUE if the two objects have the same type code
- and datum. Returns NIL otherwise.
-*/
-Built_In_Primitive(Prim_Eq, 2, "EQ?", 0xD)
-{
- Primitive_2_Args();
-
- if (Arg1 == Arg2)
- return TRUTH;
- Touch_In_Primitive(Arg1, Arg1);
- Touch_In_Primitive(Arg2, Arg2);
- return ((Arg1 == Arg2) ? TRUTH : NIL);
-}
-\f
-/* Pointer manipulation */
-
-/* (MAKE-NON-POINTER-OBJECT NUMBER)
- Returns an (extended) fixnum with the same value as NUMBER. In
- the CScheme interpreter this is basically a no-op, since fixnums
- already store 24 bits.
-*/
-Built_In_Primitive(Prim_Make_Non_Pointer, 1,
- "MAKE-NON-POINTER-OBJECT", 0xB1)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_FIXNUM);
- return Arg1;
-}
-
-/* (PRIMITIVE-DATUM OBJECT)
- Returns the datum part of OBJECT.
-*/
-Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM", 0xB0)
-{
- Primitive_1_Arg();
-
- return Make_New_Pointer(TC_ADDRESS, Arg1);
-}
-
-/* (PRIMITIVE-TYPE OBJECT)
- Returns the type code of OBJECT as a number.
- Note: THE OBJECT IS TOUCHED FIRST.
-*/
-Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE", 0x10)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- return Make_Unsigned_Fixnum(Safe_Type_Code(Arg1));
-}
-
-/* (PRIMITIVE-GC-TYPE OBJECT)
- Returns a fixnum indicating the GC type of the object. The object
- is NOT touched first.
-*/
-
-Built_In_Primitive(Prim_Gc_Type, 1, "PRIMITIVE-GC-TYPE", 0xBC)
-{
- Primitive_1_Arg();
-
- return Make_Non_Pointer(TC_FIXNUM, GC_Type(Arg1));
-}
-\f
-/* (PRIMITIVE-TYPE? TYPE-CODE OBJECT)
- Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL
- otherwise.
- Note: THE OBJECT IS TOUCHED FIRST.
-*/
-Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?", 0xF)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Touch_In_Primitive(Arg2, Arg2);
- if (Type_Code(Arg2) == Get_Integer(Arg1))
- return TRUTH;
- else
- return NIL;
-}
-
-/* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT)
- Returns a new object with TYPE-CODE and the datum part of
- OBJECT.
- Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake).
- This is a "gc-safe" (paranoid) operation.
-*/
-
-Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE", 0x11)
-{
- long New_GC_Type, New_Type;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
- Touch_In_Primitive(Arg2, Arg2);
- New_GC_Type = GC_Type_Code(New_Type);
- if ((GC_Type(Arg2) == New_GC_Type) ||
- (New_GC_Type == GC_Non_Pointer))
- return Make_New_Pointer(New_Type, Arg2);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- /*NOTREACHED*/
-}
-\f
-/* Subprimitives.
- Many primitives can be built out of these, and eventually should be.
- These are extremely unsafe, since there is no consistency checking.
- In particular, they are not gc-safe: You can screw yourself royally
- by using them.
-*/
-
-/* (&MAKE-OBJECT TYPE-CODE OBJECT)
- Makes a Scheme object whose datum field is the datum field of
- OBJECT, and whose type code is TYPE-CODE. It does not touch.
-*/
-
-Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT", 0x8D)
-{
- long New_Type;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE);
- return Make_New_Pointer(New_Type, Arg2);
-}
-
-/* (SYSTEM-MEMORY-REF OBJECT INDEX)
- Fetches the index'ed slot in object.
- Performs no type checking in object.
-*/
-
-Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF", 0x195)
-{
- Primitive_2_Args();
-
- Arg_2_Type(TC_FIXNUM);
- return Vector_Ref(Arg1, Get_Integer(Arg2));
-}
-
-/* (SYSTEM-MEMORY-SET! OBJECT INDEX VALUE)
- Stores value in the index'ed slot in object.
- Performs no type checking in object.
-*/
-
-Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!", 0x196)
-{
- long index;
- Primitive_3_Args();
-
- Arg_2_Type(TC_FIXNUM);
- index = Get_Integer(Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3);
-}
-\f
-/* Playing with the danger bit */
-
-/* (OBJECT-DANGEROUS? OBJECT)
- Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise.
-*/
-Built_In_Primitive(Prim_Dangerous_QM, 1, "OBJECT-DANGEROUS?", 0x49)
-{
- Primitive_1_Arg();
-
- return (Dangerous(Arg1)) ? TRUTH : NIL;
-}
-
-/* (MAKE-OBJECT-DANGEROUS OBJECT)
- Returns OBJECT, but with the danger bit set.
-*/
-Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS", 0x48)
-{
- Primitive_1_Arg();
-
- return Set_Danger_Bit(Arg1);
-}
-
-/* (MAKE-OBJECT-SAFE OBJECT)
- Returns OBJECT with the danger bit cleared. This does not
- side-effect the object, it merely returns a new (non-dangerous)
- pointer to the same item.
-*/
-Built_In_Primitive(Prim_Undangerize, 1, "MAKE-OBJECT-SAFE", 0x47)
-{
- Primitive_1_Arg();
-
- return Clear_Danger_Bit(Arg1);
-}
-\f
-/* Cells */
-
-/* (MAKE-CELL CONTENTS)
- Creates a cell with contents CONTENTS.
-*/
-Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL", 0x61)
-{
- Primitive_1_Arg();
-
- Primitive_GC_If_Needed(1);
- *Free++ = Arg1;
- return Make_Pointer(TC_CELL, Free-1);
-}
-
-/* (CELL-CONTENTS CELL)
- Returns the contents of the cell CELL.
-*/
-Built_In_Primitive(Prim_Cell_Contents, 1, "CELL-CONTENTS", 0x62)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_CELL);
- return(Vector_Ref(Arg1, CELL_CONTENTS));
-}
-
-/* (CELL? OBJECT)
- Returns #!TRUE if OBJECT has type-code CELL, otherwise returns
- NIL.
-*/
-Built_In_Primitive(Prim_Cell, 1, "CELL?", 0x63)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1,Arg1);
- return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL;
-}
-
-/* (SET-CELL-CONTENTS! CELL VALUE)
- Stores VALUE as contents of CELL. Returns the previous contents of CELL.
-*/
-Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CELL-CONTENTS!", 0x8C)
-{
- Primitive_2_Args();
-
- Arg_1_Type(TC_CELL);
- Side_Effect_Impurify(Arg1, Arg2);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, CELL_CONTENTS), Arg2);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.36 1987/04/16 02:27:34 jinx Rel $ */
-\f
-/*
- Primitive declarations.
-
- Note that the following cannot be changed without changing
- Findprim.c.
-*/
-
-extern Pointer (*(Primitive_Procedure_Table[]))();
-extern int Primitive_Arity_Table[];
-extern char *Primitive_Name_Table[];
-extern long MAX_PRIMITIVE;
-
-extern Pointer (*(External_Procedure_Table[]))();
-extern int External_Arity_Table[];
-extern char *External_Name_Table[];
-extern long MAX_EXTERNAL_PRIMITIVE;
-
-extern Pointer Undefined_Externals, Make_Prim_Exts();
-
-/* Utility macros */
-
-#define NUndefined() \
-((Undefined_Externals == NIL) ? \
- 0 : \
- Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))
-
-#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.22 1987/04/16 02:27:43 jinx Exp $ */
-
-/* This file contains some macros for defining primitives,
- for argument type or value checking, and for accessing
- the arguments. */
-\f
-/* Definition of primitives. */
-
-#define Define_Primitive(C_Name, Number_of_args, Scheme_Name) \
-extern Pointer C_Name(); \
-Pointer C_Name()
-
-#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name, index) \
-extern Pointer C_Name(); \
-Pointer C_Name()
-
-/* Preambles for primitive procedures. These store the arguments into
- * local variables for fast access.
- */
-
-#define Primitive_0_Args()
-
-#define Primitive_1_Args() fast Pointer Arg1 = Stack_Ref(0)
-
-#define Primitive_2_Args() Primitive_1_Args(); \
- fast Pointer Arg2 = Stack_Ref(1)
-
-#define Primitive_3_Args() Primitive_2_Args(); \
- fast Pointer Arg3 = Stack_Ref(2)
-
-#define Primitive_4_Args() Primitive_3_Args(); \
- fast Pointer Arg4 = Stack_Ref(3)
-
-#define Primitive_5_Args() Primitive_4_Args(); \
- fast Pointer Arg5 = Stack_Ref(4)
-
-#define Primitive_6_Args() Primitive_5_Args(); \
- fast Pointer Arg6 = Stack_Ref(5)
-
-#define Primitive_7_Args() Primitive_6_Args(); \
- fast Pointer Arg7 = Stack_Ref(6)
-
-#define Primitive_1_Arg() Primitive_1_Args()
-\f
-/* Various utilities */
-
-#define Primitive_Error(Err_No) \
-{ \
- signal_error_from_primitive (Err_No); \
-}
-
-#define Primitive_Interrupt() \
-{ \
- signal_interrupt_from_primitive (); \
-}
-
-#define Special_Primitive_Interrupt(Local_Mask) \
-{ \
- special_interrupt_from_primitive (Local_Mask); \
-}
-
-#define Primitive_GC(Amount) \
-{ \
- Request_GC (Amount); \
- Primitive_Interrupt (); \
-}
-
-#define Primitive_GC_If_Needed(Amount) \
-if (GC_Check (Amount)) Primitive_GC(Amount)
-
-#define Range_Check(To_Where, P, Low, High, Error) \
-{ \
- To_Where = Get_Integer (P); \
- if ((To_Where < (Low)) || (To_Where > (High))) \
- Primitive_Error (Error); \
-}
-
-#define Sign_Extend_Range_Check(To_Where, P, Low, High, Error) \
-{ \
- Sign_Extend ((P), To_Where); \
- if ((To_Where < (Low)) || (To_Where > (High))) \
- Primitive_Error (Error); \
-}
-\f
-#define Arg_1_Type(TC) \
-if ((pointer_type (Arg1)) != (TC)) error_wrong_type_arg_1 ()
-
-#define Arg_2_Type(TC) \
-if ((pointer_type (Arg2)) != (TC)) error_wrong_type_arg_2 ()
-
-#define Arg_3_Type(TC) \
-if ((pointer_type (Arg3)) != (TC)) error_wrong_type_arg_3 ()
-
-#define Arg_4_Type(TC) \
-if ((pointer_type (Arg4)) != (TC)) error_wrong_type_arg_4 ()
-
-#define Arg_5_Type(TC) \
-if ((pointer_type (Arg5)) != (TC)) error_wrong_type_arg_5 ()
-
-#define Arg_6_Type(TC) \
-if ((pointer_type (Arg6)) != (TC)) error_wrong_type_arg_6 ()
-
-#define Arg_7_Type(TC) \
-if ((pointer_type (Arg7)) != (TC)) error_wrong_type_arg_7 ()
-
-#define Arg_8_Type(TC) \
-if ((pointer_type (Arg8)) != (TC)) error_wrong_type_arg_8 ()
-
-#define Arg_9_Type(TC) \
-if ((pointer_type (Arg9)) != (TC)) error_wrong_type_arg_9 ()
-
-#define Arg_10_Type(TC) \
-if ((pointer_type (Arg10)) != (TC)) error_wrong_type_arg_10 ()
-
-
-#define Arg_1_GC_Type(GCTC) \
-if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg_1 ()
-
-#define Arg_2_GC_Type(GCTC) \
-if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg_2 ()
-
-#define Arg_3_GC_Type(GCTC) \
-if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg_3 ()
-\f
-#define guarantee_fixnum_arg_1() \
-if (! (fixnum_p (Arg1))) error_wrong_type_arg_1 ()
-
-#define guarantee_fixnum_arg_2() \
-if (! (fixnum_p (Arg2))) error_wrong_type_arg_2 ()
-
-#define guarantee_fixnum_arg_3() \
-if (! (fixnum_p (Arg3))) error_wrong_type_arg_3 ()
-
-#define guarantee_fixnum_arg_4() \
-if (! (fixnum_p (Arg4))) error_wrong_type_arg_4 ()
-
-#define guarantee_fixnum_arg_5() \
-if (! (fixnum_p (Arg5))) error_wrong_type_arg_5 ()
-
-#define guarantee_fixnum_arg_6() \
-if (! (fixnum_p (Arg6))) error_wrong_type_arg_6 ()
-
-extern long guarantee_nonnegative_int_arg_1();
-extern long guarantee_nonnegative_int_arg_2();
-extern long guarantee_nonnegative_int_arg_3();
-extern long guarantee_nonnegative_int_arg_4();
-extern long guarantee_nonnegative_int_arg_5();
-extern long guarantee_nonnegative_int_arg_6();
-extern long guarantee_nonnegative_int_arg_7();
-extern long guarantee_nonnegative_int_arg_8();
-extern long guarantee_nonnegative_int_arg_9();
-extern long guarantee_nonnegative_int_arg_10();
-
-extern long guarantee_index_arg_1();
-extern long guarantee_index_arg_2();
-extern long guarantee_index_arg_3();
-extern long guarantee_index_arg_4();
-extern long guarantee_index_arg_5();
-extern long guarantee_index_arg_6();
-extern long guarantee_index_arg_7();
-extern long guarantee_index_arg_8();
-extern long guarantee_index_arg_9();
-extern long guarantee_index_arg_10();
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.40 1987/04/16 14:34:28 jinx Rel $
- *
- * This file contains the support routines for mapping primitive names
- * to numbers within the microcode. This mechanism is only used by
- * the runtime system on "external" primitives. "Built-in" primitives
- * must match their position in utabmd.scm. Eventually both
- * mechanisms will be merged. External primitives are written in C
- * and available in Scheme, but not always present in all versions of
- * the interpreter. Thus, these objects are always referenced
- * externally by name and converted to numeric references only for the
- * duration of a single Scheme session.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* Common utilities. */
-
-/* In the following two procedures, size is really 1 less than size.
- It is really the index of the last valid entry.
- */
-
-long
-primitive_name_to_code(name, table, size)
- char *name;
- char *table[];
- long size;
-{
- fast long i;
-
- for (i = size; i >= 0; i -= 1)
- {
- fast char *s1, *s2;
-
- s1 = name;
- s2 = table[i];
-
- while (*s1++ == *s2)
- if (*s2++ == '\0')
- return i;
-
- }
- return -1;
-}
-
-char *
-primitive_code_to_name(code, table, size)
- long code;
- char *table[];
- long size;
-{
- if ((code > size) || (code < 0))
- return ((char *) NULL);
- else
- return table[code];
-}
-
-int
-primitive_code_to_arity(code, table, size)
- long code;
- int table[];
- long size;
-{
- if ((code > size) || (code < 0))
- return -1;
- else
- return table[code];
-}
-\f
-/* Utilities exclusively for built-in primitives. */
-
-extern Pointer make_primitive();
-
-Pointer
-make_primitive(name)
- char *name;
-{
- long code;
-
- code = primitive_name_to_code(name,
- &Primitive_Name_Table[0],
- MAX_PRIMITIVE);
- if (code == -1)
- return NIL;
- return
- Make_Non_Pointer(TC_PRIMITIVE, code);
-}
-
-extern long primitive_to_arity();
-
-long
-primitive_to_arity(code)
- int code;
-{
- return
- primitive_code_to_arity(code,
- &Primitive_Arity_Table[0],
- MAX_PRIMITIVE);
-}
-
-extern char *primitive_to_name();
-
-char *
-primitive_to_name(code)
- int code;
-{
- return
- primitive_code_to_name(code,
- &Primitive_Name_Table[0],
- MAX_PRIMITIVE);
-}
-\f
-/* Utilities exclusively for external primitives. */
-
-Pointer Undefined_Externals = NIL;
-
-Pointer
-external_primitive_name(code)
- long code;
-{
- extern Pointer string_to_symbol();
-
- return
- string_to_symbol(C_String_To_Scheme_String(External_Name_Table[code]));
-}
-
-extern long make_external_primitive();
-
-long
-make_external_primitive(Symbol, Intern_It)
- Pointer Symbol, Intern_It;
-{
- extern Boolean string_equal();
- Pointer *Next, Name;
- long i, Max;
-
- Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME);
-
- i = primitive_name_to_code(Scheme_String_To_C_String(Name),
- &External_Name_Table[0],
- MAX_EXTERNAL_PRIMITIVE);
- if (i != -1)
- return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, i);
- else if (Intern_It == NIL)
- return NIL;
-
- Max = NUndefined();
- if (Max > 0)
- Next = Nth_Vector_Loc(Undefined_Externals, 2);
-
- for (i = 1; i <= Max; i++)
- {
- if (string_equal(Name, Fast_Vector_Ref(*Next++, SYMBOL_NAME)))
- return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL,
- (MAX_EXTERNAL_PRIMITIVE + i));
- }
- if (Intern_It != TRUTH)
- return NIL;
-\f
- /* Intern the primitive name by adding it to the vector of
- undefined primitives */
-
- if ((Max % CHUNK_SIZE) == 0)
- {
- Primitive_GC_If_Needed(Max + CHUNK_SIZE + 2);
- if (Max > 0) Next =
- Nth_Vector_Loc(Undefined_Externals, 2);
- Undefined_Externals = Make_Pointer(TC_VECTOR, Free);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1));
- *Free++ = Make_Unsigned_Fixnum(Max + 1);
- for (i = 0; i < Max; i++)
- *Free++ = Fetch(*Next++);
- *Free++ = Symbol;
- for (i = 1; i < CHUNK_SIZE; i++)
- *Free++ = NIL;
- }
- else
- {
- User_Vector_Set(Undefined_Externals, (Max + 1), Symbol);
- User_Vector_Set(Undefined_Externals, 0, Make_Unsigned_Fixnum(Max + 1));
- }
- return
- Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL,
- (MAX_EXTERNAL_PRIMITIVE + Max + 1));
-}
-\f
-extern long external_primitive_to_arity();
-
-long
-external_primitive_to_arity(code)
- int code;
-{
- return
- primitive_code_to_arity(code,
- &External_Arity_Table[0],
- MAX_EXTERNAL_PRIMITIVE);
-}
-\f
-extern Pointer Make_Prim_Exts();
-
-/*
- Used to create a vector with symbols for each of the external
- primitives known to the system.
-*/
-
-Pointer
-Make_Prim_Exts()
-{
- fast Pointer Result, *scan;
- fast long i, Max, Count;
-
- Max = NUndefined();
- Count = (MAX_EXTERNAL_PRIMITIVE + Max + 1);
- Primitive_GC_If_Needed(Count + 1);
- Result = Make_Pointer(TC_VECTOR, Free);
- scan = Free;
- Free += Count + 1;
-
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
- for (i = 0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
- {
- *scan++ = external_primitive_name(i);
- }
- for (i = 1; i <= Max; i++)
- {
- *scan++ = User_Vector_Ref(Undefined_Externals, i);
- }
- return Result;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/pruxfs.c,v 9.21 1987/01/22 14:34:49 jinx Exp $
-
- Simple unix primitives.
-
-*/
-\f
-#include <pwd.h>
-#include "scheme.h"
-#include "primitive.h"
-
-/* Looks up in the user's shell environment the value of the
- variable specified as a string. */
-
-Define_Primitive( Prim_get_environment_variable, 1, "GET-ENVIRONMENT-VARIABLE")
-{
- char *variable_value;
- extern char *getenv();
- Primitive_1_Arg();
-
- Arg_1_Type( TC_CHARACTER_STRING);
- variable_value = getenv( Scheme_String_To_C_String( Arg1));
- return ((variable_value == NULL)
- ? NIL
- : C_String_To_Scheme_String( variable_value));
-}
-
-Define_Primitive( Prim_get_user_name, 0, "CURRENT-USER-NAME")
-{
- char *user_name;
- char *getlogin();
- Primitive_0_Args();
-
- user_name = getlogin();
- if (user_name == NULL)
- {
- unsigned short getuid();
- struct passwd *entry;
- struct passwd *getpwuid();
-
- entry = getpwuid( getuid());
- if (entry == NULL)
- Primitive_Error( ERR_EXTERNAL_RETURN);
- user_name = entry->pw_name;
- }
- return (C_String_To_Scheme_String( user_name));
-}
-
-Define_Primitive( Prim_get_user_home_directory, 1, "GET-USER-HOME-DIRECTORY")
-{
- struct passwd *entry;
- struct passwd *getpwnam();
- Primitive_1_Arg();
-
- Arg_1_Type( TC_CHARACTER_STRING);
- entry = getpwnam( Scheme_String_To_C_String( Arg1));
- return ((entry == NULL)
- ? NIL
- : C_String_To_Scheme_String( entry->pw_dir));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $
- *
- * This file contains macros and declarations for Bintopsb.c
- * and Psbtobin.c
- *
- */
-\f
-/* These definitions insure that the appropriate code is extracted
- from the included files.
-*/
-
-#include <stdio.h>
-#define fast register
-
-#include "config.h"
-#include "object.h"
-#include "bignum.h"
-#include "gc.h"
-#include "types.h"
-#include "sdata.h"
-#include "const.h"
-#include "gccode.h"
-#include "character.h"
-
-#ifdef HAS_FREXP
-extern double frexp(), ldexp();
-#else
-#include "missing.c"
-#endif
-
-#define PORTABLE_VERSION 1
-
-/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently the dumped object and the external
- primitives vector.
- */
-
-#define NROOTS 2
-
-/* Types to recognize external object references. Any occurrence of these
- (which are external types and thus handled separately) means a reference
- to an external object.
- */
-
-#define CONSTANT_CODE TC_BIG_FIXNUM
-#define HEAP_CODE TC_FIXNUM
-
-#define fixnum_to_bits FIXNUM_LENGTH
-#define bignum_to_bits(len) ((len) * SHIFT)
-#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
-
-#define hex_digits(nbits) (((nbits) + 3) / 4)
-
-#define to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
-
-/* This assumes that a bignum header is 2 Pointers.
- The bignum code is not very portable, unfortunately */
-
-#define bignum_header_to_pointer Align(0)
-
-#define float_to_pointer \
- to_pointer(sizeof(double))
-#define flonum_to_pointer(nchars) \
- ((nchars) * (1 + float_to_pointer))
-
-#define char_to_pointer(nchars) \
- to_pointer(nchars)
-#define pointer_to_char(npoints) \
- ((npoints) * sizeof(Pointer))
-\f
-/* Global data */
-
-/* If true, make all integers fixnums if possible, and all strings as
- short as possible (trim extra stuff). */
-
-static Boolean Compact_P = true;
-
-/* If true, null out all elements of random non-marked vectors. */
-
-static Boolean Null_NMV = false;
-
-#ifndef Heap_In_Low_Memory
-static Pointer *Memory_Base;
-#endif
-
-static FILE *Input_File, *Output_File;
-
-static char *Program_Name;
-\f
-/* Status flags */
-
-#define COMPACT_P 1
-#define NULL_NMV 2
-
-#define Make_Flags() \
-((Compact_P ? COMPACT_P : 0) | \
- (Null_NMV ? NULL_NMV : 0))
-
-#define Read_Flags(f) \
-Compact_P = ((f) & COMPACT_P); \
-Null_NMV = ((f) & NULL_NMV)
-\f
-/* Argument List Parsing */
-
-struct Option_Struct { char *name;
- Boolean value;
- Boolean *ptr;
- };
-
-Boolean strequal(s1, s2)
-fast char *s1, *s2;
-{ while (*s1 != '\0')
- if (*s1++ != *s2++) return false;
- return (*s2 == '\0');
-}
-
-char *Find_Options(argc, argv, Noptions, Options)
-int argc;
-char **argv;
-int Noptions;
-struct Option_Struct Options[];
-{ for ( ; --argc >= 0; argv++)
- { char *this = *argv;
- int n;
- for (n = 0;
- ((n < Noptions) && (!strequal(this, Options[n].name)));
- n++) ;
- if (n >= Noptions) return this;
- *(Options[n].ptr) = Options[n].value;
- }
- return NULL;
-}
-\f
-/* Usage information */
-
-Print_Options(n, options, where)
-int n;
-struct Option_Struct *options;
-FILE *where;
-{ if (--n < 0) return;
- fprintf(where, "[%s]", options->name);
- options += 1;
- for (; --n >= 0; options += 1)
- fprintf(where, " [%s]", options->name);
- return;
-}
-
-Print_Usage_and_Exit(noptions, options, io_options)
-int noptions;
-struct Option_Struct *options;
-char *io_options;
-{ fprintf(stderr, "usage: %s%s%s",
- Program_Name,
- (((io_options == NULL) ||
- (io_options[0] == '\0')) ? "" : " "),
- io_options);
- if (noptions != 0)
- { putc(' ', stderr);
- Print_Options(noptions, options, stderr);
- }
- putc('\n', stderr);
- exit(1);
-}
-\f
-/* Top level of program */
-
-/* When debugging force arguments on command line */
-
-#ifdef DEBUG
-#undef unix
-#endif
-
-#ifdef unix
-
-/* On unix use io redirection */
-
-Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
- Program_Name = argv[0];
- Input_File = stdin;
- Output_File = stdout;
- if (((argc - 1) > Noptions) ||
- (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
- Print_Usage_and_Exit(Noptions, Options, "");
- do_it();
- return;
-}
-
-#else
-
-/* Otherwise use command line arguments */
-
-Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
- Program_Name = argv[0];
- if ((argc < 3) ||
- ((argc - 3) > Noptions) ||
- (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
- Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
- Input_File = ((strequal(argv[1], "-")) ?
- stdin :
- fopen(argv[1], "r"));
- if (Input_File == NULL)
- { perror("Open failed.");
- exit(1);
- }
- Output_File = ((strequal(argv[2], "-")) ?
- stdout :
- fopen(argv[2], "w"));
- if (Output_File == NULL)
- { perror("Open failed.");
- fclose(Input_File);
- exit(1);
- }
- fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
- Program_Name, argv[1], argv[2]);
- do_it();
- fclose(Input_File);
- fclose(Output_File);
- return;
-}
-
-#endif
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $
- *
- * This File contains the code to translate portable format binary
- * files to internal format.
- *
- */
-\f
-/* Cheap renames */
-
-#define Portable_File Input_File
-#define Internal_File Output_File
-
-#include "translate.h"
-
-static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
-static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
-static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
-static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
-static Pointer *Heap;
-static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
-static Pointer *Constant_Base, *Constant_Table,
- *Constant_Object_Base, *Free_Constant;
-static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
-static Pointer *Stack_Top;
-
-Write_Data(Count, From_Where)
-long Count;
-Pointer *From_Where;
-{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
-}
-
-#include "dump.c"
-\f
-#define OUT(c) return ((long) ((c) & MAX_CHAR))
-
-long read_a_char()
-{ fast char C = getc(Portable_File);
- if (C != '\\') OUT(C);
- C = getc(Portable_File);
- switch(C)
- { case 'n': OUT('\n');
- case 't': OUT('\n');
- case 'r': OUT('\r');
- case 'f': OUT('\f');
- case '0': OUT('\0');
- case 'X':
- { long Code;
- fprintf(stderr,
- "%s: File is not Portable. Character Code Found.\n",
- Program_Name);
- fscanf(Portable_File, "%d", &Code);
- getc(Portable_File); /* Space */
- OUT(Code);
- }
- case '\\': OUT('\\');
- default : OUT(C);
- }
-}
-\f
-Pointer *read_a_string(To, Slot)
-Pointer *To, *Slot;
-{ long maxlen, len, Pointer_Count;
- fast char *string = ((char *) (&To[STRING_CHARS]));
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld %ld", &maxlen, &len);
- maxlen += 1; /* Null terminated */
- Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
- To[STRING_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
- getc(Portable_File); /* Space */
- while (--len >= 0) *string++ = ((char) read_a_char());
- *string = '\0';
- return (To + Pointer_Count);
-}
-\f
-Pointer *read_an_integer(The_Type, To, Slot)
-int The_Type;
-Pointer *To;
-Pointer *Slot;
-{ Boolean negative;
- long size_in_bits;
-
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld", &size_in_bits);
- if ((size_in_bits <= fixnum_to_bits) &&
- (The_Type == TC_FIXNUM))
- { fast long Value = 0;
- fast int Normalization;
- fast long ndigits;
- long digit;
- if (size_in_bits != 0)
- for(Normalization = 0,
- ndigits = hex_digits(size_in_bits);
- --ndigits >= 0;
- Normalization += 4)
- { fscanf(Portable_File, "%1lx", &digit);
- Value += (digit << Normalization);
- }
- if (negative) Value = -Value;
- *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
- return To;
- }
- else if (size_in_bits == 0)
- { bigdigit *REG = BIGNUM(To);
- Prepare_Header(REG, 0, POSITIVE);
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Align(0));
- }
- else
- { fast bigdigit *The_Bignum;
- fast long size, nbits, ndigits;
- fast unsigned long Temp;
- long Length;
- if ((The_Type == TC_FIXNUM) && (!Compact_P))
- fprintf(stderr,
- "%s: Fixnum too large, coercing to bignum.\n",
- Program_Name);
- size = bits_to_bigdigit(size_in_bits);
- ndigits = hex_digits(size_in_bits);
- Length = Align(size);
- The_Bignum = BIGNUM(To);
- Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE));
- for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0;
- --size >= 0;
- )
- { for ( ;
- (nbits < SHIFT) && (ndigits > 0);
- ndigits -= 1, nbits += 4)
- { long digit;
- fscanf(Portable_File, "%1lx", &digit);
- Temp |= (((unsigned long) digit) << nbits);
- }
- *The_Bignum++ = Rem_Radix(Temp);
- Temp = Div_Radix(Temp);
- nbits -= SHIFT;
- }
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Length);
- }
-}
-\f
-/* Underflow and Overflow */
-
-/* dflmax and dflmin exist in the Berserkely FORTRAN library */
-
-static double the_max = 0.0;
-
-#define dflmin() 0.0 /* Cop out */
-#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
-
-double compute_max()
-{ fast double Result = 0.0;
- fast int expt;
- for (expt = MAX_FLONUM_EXPONENT;
- expt != 0;
- expt >>= 1)
- Result += ldexp(1.0, expt);
- the_max = Result;
- return Result;
-}
-\f
-double read_a_flonum()
-{ Boolean negative;
- long size_in_bits, exponent;
- fast double Result;
-
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
- if (size_in_bits == 0) Result = 0.0;
- else if ((exponent > MAX_FLONUM_EXPONENT) ||
- (exponent < -MAX_FLONUM_EXPONENT))
- { /* Skip over mantissa */
- while (getc(Portable_File) != '\n') ;
- fprintf(stderr,
- "%s: Floating point exponent too %s!\n",
- Program_Name,
- ((exponent < 0) ? "small" : "large"));
- Result = ((exponent < 0) ? dflmin() : dflmax());
- }
- else
- { fast long ndigits;
- fast double Normalization;
- long digit;
- if (size_in_bits > FLONUM_MANTISSA_BITS)
- fprintf(stderr,
- "%s: Some precision may be lost.",
- Program_Name);
- getc(Portable_File); /* Space */
- for (ndigits = hex_digits(size_in_bits),
- Result = 0.0,
- Normalization = (1.0 / 16.0);
- --ndigits >= 0;
- Normalization /= 16.0)
- {
- fscanf(Portable_File, "%1lx", &digit);
- Result += (((double ) digit) * Normalization);
- }
- Result = ldexp(Result, ((int) exponent));
- }
- if (negative) Result = -Result;
- return Result;
-}
-\f
-Pointer *
-Read_External(N, Table, To)
- long N;
- fast Pointer *Table, *To;
-{
- fast Pointer *Until = &Table[N];
- int The_Type;
-
- while (Table < Until)
- {
- fscanf(Portable_File, "%2x", &The_Type);
- switch(The_Type)
- {
- case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
- continue;
- case TC_FIXNUM:
- case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
- continue;
- case TC_CHARACTER:
- {
- long the_char_code;
-
- getc(Portable_File); /* Space */
- fscanf( Portable_File, "%3x", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
- continue;
- }
- case TC_BIG_FLONUM:
- {
- double The_Flonum = read_a_flonum();
-
- Align_Float(To);
- *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
- *((double *) To) = The_Flonum;
- To += float_to_pointer;
- continue;
- }
- default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
- exit(1);
- }
- }
- return To;
-}
-\f
-#if false
-Move_Memory(From, N, To)
-fast Pointer *From, *To;
-long N;
-{ fast Pointer *Until = &From[N];
- while (From < Until) *To++ = *From++;
- return;
-}
-#endif
-
-Relocate_Objects(From, N, disp)
-fast Pointer *From;
-long N;
-fast long disp;
-{ fast Pointer *Until = &From[N];
- while (From < Until)
- { switch(Type_Code(*From))
- { case TC_FIXNUM:
- case TC_CHARACTER:
- From += 1;
- break;
- case TC_BIG_FIXNUM:
- case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From)));
- break;
- default:
- fprintf(stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- Program_Name,
- Type_Code(*From));
- }
- }
-}
-\f
-#define Relocate_Into(Where, Addr) \
-if ((Addr) < Dumped_Pure_Base) \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
-else if ((Addr) < Dumped_Constant_Base) \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
-else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base];
-
-#ifndef Conditional_Bug
-
-#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
- &Constant_Base[(Addr) - Dumped_Constant_Base]))
-
-#else
-static Pointer *Relocate_Temp;
-#define Relocate(Addr) \
- (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
-#endif
-
-Pointer *Read_Pointers_and_Relocate(N, To)
-fast long N;
-fast Pointer *To;
-{ int The_Type;
- long The_Datum;
-/* Align_Float(To); */
- while (--N >= 0)
- { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- switch(The_Type)
- { case CONSTANT_CODE:
- *To++ = Constant_Table[The_Datum];
- continue;
-
- case HEAP_CODE:
- *To++ = Heap_Table[The_Datum];
- continue;
-
- case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV)) /* Unknown object! */
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- { fast long count = The_Datum;
- N -= count;
- while (--count >= 0)
- { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- }
- }
- continue;
-
- case TC_BROKEN_HEART:
- if (The_Datum != 0)
- { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
- exit(1);
- }
- /* Fall Through */
- case TC_PRIMITIVE_EXTERNAL:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_simple_Non_Pointer:
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- continue;
-
- case TC_REFERENCE_TRAP:
- if (The_Datum <= TRAP_MAX_IMMEDIATE)
- {
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- continue;
- }
- /* It is a pointer, fall through. */
- default:
- /* Should be stricter */
- *To++ = Make_Pointer(The_Type, Relocate(The_Datum));
- continue;
- }
- }
-/* Align_Float(To); */
- return To;
-}
-\f
-#ifdef DEBUG
-Print_External_Objects(area_name, Table, N)
-char *area_name;
-fast Pointer *Table;
-fast long N;
-{ fast Pointer *Table_End = &Table[N];
-
- fprintf(stderr, "%s External Objects:\n", area_name);
- fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
-
- for( ; Table < Table_End; Table++)
- switch (Type_Code(*Table))
- { case TC_FIXNUM:
- { long The_Number;
- Sign_Extend(*Table, The_Number);
- fprintf(stderr,
- "Table[%6d] = Fixnum %d\n",
- (N-(Table_End-Table)),
- The_Number);
- break;
- }
- case TC_CHARACTER:
- fprintf(stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N-(Table_End-Table)),
- Get_Integer(*Table),
- Get_Integer(*Table));
- break;
-
-/* Print_External_Objects continues on the next page */
-\f
-/* Print_External_Objects, continued */
-
- case TC_CHARACTER_STRING:
- fprintf(stderr,
- "Table[%6d] = string \"%s\"\n",
- (N-(Table_End-Table)),
- ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
- break;
- case TC_BIG_FIXNUM:
- fprintf(stderr,
- "Table[%6d] = Bignum\n",
- (N-(Table_End-Table)));
- break;
- case TC_BIG_FLONUM:
- fprintf(stderr,
- "Table[%6d] = Flonum %lf\n",
- (N-(Table_End-Table)),
- (* ((double *) Nth_Vector_Loc(*Table, 1))));
- break;
- default:
- fprintf(stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N-(Table_End-Table)),
- *Table);
- break;
- }
-}
-#endif
-\f
-long Read_Header_and_Allocate()
-{ long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NStrings, NBits, NChars;
- long Size;
-
- /* Read Header */
-
- fscanf(Input_File, "%ld %ld %ld %ld",
- &Portable_Version, &Flags, &Version, &Sub_Version);
- fscanf(Input_File, "%ld %ld %ld",
- &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
- fscanf(Input_File, "%ld %ld %ld",
- &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
- fscanf(Input_File, "%ld %ld %ld",
- &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
- fscanf(Input_File, "%ld %ld %ld %ld %ld",
- &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
- fscanf(Input_File, "%ld %ld",
- &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
-
- if ((Portable_Version != PORTABLE_VERSION) ||
- (Version != FASL_FORMAT_VERSION) ||
- (Sub_Version != FASL_SUBVERSION))
- { fprintf(stderr,
- "FASL File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version , Portable_Version);
- fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
- exit(1);
- }
-
- Read_Flags(Flags);
-
- Size = (6 + /* SNMV */
- HEAP_BUFFER_SPACE +
- Heap_Count + Heap_Objects +
- Constant_Count + Constant_Objects +
- Pure_Count + Pure_Objects +
- flonum_to_pointer(NFlonums) +
- ((NIntegers * bignum_header_to_pointer) +
- (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
- ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
-
- Allocate_Heap_Space(Size);
- if (Heap == NULL)
- { fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
- exit(1);
- }
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
- return (Size - HEAP_BUFFER_SPACE);
-}
-\f
-do_it()
-{ long Size;
- Size = Read_Header_and_Allocate();
- Stack_Top = &Heap[Size];
-
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- Heap_Object_Base =
- Read_External(Heap_Objects, Heap_Table, Heap_Base);
-
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
- Pure_Object_Base =
- Read_External(Pure_Objects, Pure_Table, Pure_Base);
-
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
- Constant_Object_Base =
- Read_External(Constant_Objects, Constant_Table, Constant_Base);
-
-#ifdef DEBUG
- Print_External_Objects("Heap", Heap_Table, Heap_Objects);
- Print_External_Objects("Pure", Pure_Table, Pure_Objects);
- Print_External_Objects("Constant", Constant_Table, Constant_Objects);
-#endif
-\f
- /* Read the normal objects */
-
- Free =
- Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
- Free_Pure =
- Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
- Free_Constant =
- Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
-
- /* Dump the objects */
-
- { Pointer *Dumped_Object, *Dumped_Ext_Prim;
- Relocate_Into(Dumped_Object, Dumped_Object_Addr);
- Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumping:\n");
- fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base));
- fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base));
- fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base));
- fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object);
- fprintf(stderr,
- "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
- Dumped_Ext_Prim, *Dumped_Ext_Prim);
-#endif
-
- /* Is there a Pure/Constant block? */
-
- if ((Constant_Objects == 0) && (Constant_Count == 0) &&
- (Pure_Objects == 0) && (Pure_Count == 0))
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
- else
- { long Pure_Length = (Constant_Base - Pure_Base) + 1;
- long Total_Length = (Free_Constant - Pure_Base) + 4;
- Pure_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
- Pure_Base[-1] =
- Make_Non_Pointer(PURE_PART, Total_Length);
- Constant_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Constant_Base[-1] =
- Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
- Free_Constant[0] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Free_Constant[1] =
- Make_Non_Pointer(END_OF_BLOCK, Total_Length);
-
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
- }
- }
- return;
-}
-\f
-/* Top level */
-
-static int Noptions = 0;
-/* C does not usually like empty initialized arrays, so ... */
-static struct Option_Struct Options[] = {{"dummy", true, NULL}};
-
-main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.26 1987/04/16 02:27:53 jinx Exp $
- *
- * This file contains the code that copies objects into pure
- * and constant space.
- *
- */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "gccode.h"
-#include "zones.h"
-
-/* Imports */
-
-extern void GCFlip(), GC();
-extern Pointer *GCLoop();
-\f
-/* This is a copy of GCLoop, with GC_Mode handling added, and
- debugging printout removed.
-*/
-
-#define Purify_Pointer(Code) \
-Old = Get_Pointer(Temp); \
-if ((GC_Mode == CONSTANT_COPY) && \
- (Old > Low_Constant)) \
- continue; \
-Code
-
-#define Setup_Pointer_for_Purify(Extra_Code) \
-Purify_Pointer(Setup_Pointer(false, Extra_Code))
-
-#define Indirect_BH(In_GC) \
-if (Type_Code(*Old) == TC_BROKEN_HEART) continue;
-
-#define Transport_Vector_Indirect() \
-Real_Transport_Vector(); \
-*Get_Pointer(Temp) = New_Address
-\f
-Pointer *PurifyLoop(Scan, To_Pointer, GC_Mode)
-fast Pointer *Scan;
-Pointer **To_Pointer;
-int GC_Mode;
-{ fast Pointer *To, *Old, Temp, *Low_Constant, New_Address;
-
- To = *To_Pointer;
- Low_Constant = Constant_Space;
- for ( ; Scan != To; Scan++)
- { Temp = *Scan;
- Switch_by_GC_Type(Temp)
- { case TC_BROKEN_HEART:
- if (Scan == (Get_Pointer(Temp)))
- { *To_Pointer = To;
- return Scan;
- }
- fprintf(stderr, "Purify: Broken heart in scan.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += Get_Integer(Temp);
- break;
-
- case_Non_Pointer:
- break;
-
- case_compiled_entry_point:
- if (GC_Mode == PURE_COPY) break;
- Purify_Pointer(Setup_Internal(false,
- Transport_Compiled(),
- Compiled_BH(false, continue)));
-
- case_Cell:
- Setup_Pointer_for_Purify(Transport_Cell());
-
-/* PurifyLoop continues on the next page */
-\f
-/* PurifyLoop, continued */
-
- /*
- Symbols, variables, and reference traps cannot be put into
- pure space. The strings contained in the first two can, on the
- other hand.
- */
-
- case TC_REFERENCE_TRAP:
- if ((Datum(Temp) <= TRAP_MAX_IMMEDIATE) || (GC_Mode == PURE_COPY))
- {
- /* It is a non pointer. */
- break;
- }
- goto purify_pair;
-
- case TC_INTERNED_SYMBOL:
- case TC_UNINTERNED_SYMBOL:
- if (GC_Mode == PURE_COPY)
- { Temp = Vector_Ref(Temp, SYMBOL_NAME);
- Purify_Pointer(Setup_Internal(false,
- Transport_Vector_Indirect(),
- Indirect_BH(false)));
- }
- /* Fall through */
- case_Fasdump_Pair:
- purify_pair:
- Setup_Pointer_for_Purify(Transport_Pair());
-
- case TC_WEAK_CONS:
- Setup_Pointer_for_Purify(Transport_Weak_Cons());
-
- case TC_VARIABLE:
- case_Triple:
- Setup_Pointer_for_Purify(Transport_Triple());
-
-/* PurifyLoop continues on the next page */
-\f
-/* PurifyLoop, continued */
-
- case_Quadruple:
- Setup_Pointer_for_Purify(Transport_Quadruple());
-
- /* No need to handle futures specially here, since PurifyLoop
- is always invoked after running GCLoop, which will have
- spliced all spliceable futures unless the GC itself of the
- GC dameons spliced them, but this should not occur.
- */
-
- case TC_FUTURE:
- case TC_ENVIRONMENT:
- if (GC_Mode == PURE_COPY)
- {
- /* This should actually do an indirect pair transport of
- the procedure, at least.
- */
- break;
- }
- /* Fall through */
-#ifndef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- /* Fall through */
-#endif
- case_Purify_Vector:
- purify_vector:
- Setup_Pointer_for_Purify(Transport_Vector());
-
-#ifdef FLOATING_ALIGNMENT
- case TC_BIG_FLONUM:
- Setup_Pointer_for_Purify(Transport_Flonum());
-#endif
-
- default:
- fprintf(stderr,
- "PurifyLoop: Bad type code = 0x%02x\n",
- Type_Code(Temp));
- Invalid_Type_Code();
- } /* Switch_by_GC_Type */
- } /* For loop */
- *To_Pointer = To;
- return To;
-} /* PurifyLoop */
-\f
-/* Description of the algorithm for PURIFY:
-
- The algorithm is trickier than would first appear necessary. This
- is because the size of the object being purified must be
- calculated. The idea is that the entire object is copied into the
- new heap, and then a normal GC is done (the broken hearts created
- by the copy will, of course, now be used to relocate references to
- parts of the object). If there is not enough room in constant
- space for the object, processing stops with a #!false return and
- the world flipped into the new heap. Otherwise, the
- process is repeated, moving the object into constant space on the
- first pass and then doing a GC back into the original heap.
-
- Notice that in order to make a pure object, the copy process
- proceeds in two halves. During the first half (which collects the
- pure part) Compiled Code, Environments, Symbols, and Variables
- (i.e. things whose contents change) are NOT copied. Then a header
- is put down indicating constant (not pure) area, and then they ARE
- copied.
-
- The constant area contains a contiguous set of blocks of the
- following format:
-
- >>Top of Memory (Stack above here)<<
-
- . (direction of growth)
- . ^
- . / \
- . |
- . |
- |----------------------|...
- | END | Total Size M | . Where END = TC_FIXNUM
- |----------------------| . SNMH = TC_MANIFEST_SPECIAL_...
- | SNMH | 1 | | CONST = TC_TRUE
- |----------------------| | PURE = TC_FALSE
- | | |
- | | |
- | CONSTANT AREA | |
- | | |
- | | .
- ...|----------------------| > M
- . | CONST | Pure Size N | .
- . |----------------------| |
- | | SNMH | 1 | |
- | |----------------------| |
- | | | |
-N < | | |
- | | PURE AREA | |
- | | | |
- . | | .
- . |----------------------| .
- ...| PURE | Total Size M |...
- |----------------------|
- | SNMH | Pure Size N |
- |----------------------|
-
- >>Base of Memory (Heap below here)<<
-*/
-\f
-/* The result returned by Purify is a vector containing this data */
-
-#define Purify_Vector_Header 0
-#define Purify_Length 1
-#define Purify_Really_Pure 2
-#define Purify_N_Slots 2
-
-Pointer Purify(Object, Purify_Object)
-Pointer Object, Purify_Object;
-{ long Length;
- Pointer *Heap_Start, *Result, Answer;
-
-/* Pass 1 -- Copy object to new heap, then GC into that heap */
-
- GCFlip();
- Heap_Start = Free;
- *Free++ = Object;
- Result = GCLoop(Heap_Start, &Free);
- if (Free != Result)
- { fprintf(stderr, "\Purify: Pure Scan ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- Length = (Free-Heap_Start)-1; /* Length of object */
- GC();
- Free[Purify_Vector_Header] =
- Make_Non_Pointer(TC_MANIFEST_VECTOR, Purify_N_Slots);
- Free[Purify_Length] = Make_Unsigned_Fixnum(Length);
- Free[Purify_Really_Pure] = Purify_Object;
- Answer = Make_Pointer(TC_VECTOR, Free);
- Free += Purify_N_Slots+1;
- return Answer;
-}
-\f
-Pointer Purify_Pass_2(Info)
-Pointer Info;
-{ long Length = Get_Integer(Fast_Vector_Ref(Info, Purify_Length));
- Boolean Purify_Object;
- Pointer *New_Object, Relocated_Object, *Result, Answer;
- long Pure_Length, Recomputed_Length;
-
- if (Fast_Vector_Ref(Info, Purify_Really_Pure) == NIL)
- Purify_Object = false;
- else Purify_Object = true;
- Relocated_Object = *Heap_Bottom;
- if (!Test_Pure_Space_Top(Free_Constant+Length+6))
- return NIL;
- New_Object = Free_Constant;
- GCFlip();
- *Free_Constant++ = NIL; /* Will hold pure space header */
- *Free_Constant++ = Relocated_Object;
- if (Purify_Object)
- { Result = PurifyLoop(New_Object+1, &Free_Constant, PURE_COPY);
- if (Free_Constant != Result)
- { fprintf(stderr, "\Purify: Pure Copy ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- Pure_Length = (Free_Constant-New_Object) + 1;
- }
- else Pure_Length = 3;
- *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Free_Constant++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
- if (Purify_Object)
- { Result = PurifyLoop(New_Object + 1, &Free_Constant, CONSTANT_COPY);
- if (Result != Free_Constant)
- { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- }
-
-/* Purify_Pass_2 continues on the next page */
-\f
-/* Purify_Pass_2, continued */
-
- else
- { Result = GCLoop(New_Object + 1, &Free_Constant);
- if (Result != Free_Constant)
- { fprintf(stderr, "\Purify: Constant Copy ended too early.\n");
- Microcode_Termination(TERM_BROKEN_HEART);
- }
- }
- Recomputed_Length = (Free_Constant-New_Object)-4;
- *Free_Constant++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Free_Constant++ = Make_Non_Pointer(END_OF_BLOCK, Recomputed_Length+5);
- if (Length > Recomputed_Length)
- { printf("Purify phase error %x, %x\n", Length, Recomputed_Length);
- Microcode_Termination(TERM_EXIT);
- }
- *New_Object++ =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
- *New_Object = Make_Non_Pointer(PURE_PART, Recomputed_Length+5);
- GC();
- Set_Pure_Top();
- return TRUTH;
-}
-\f
-/* (PRIMITIVE-PURIFY OBJECT PURE?)
- Copy an object from the heap into constant space. This requires
- a spare heap, and is tricky to use -- it should only be used
- through the wrapper provided in the Scheme runtime system.
-
- To purify an object we just copy it into Pure Space in two
- parts with the appropriate headers and footers. The actual
- copying is done by PurifyLoop above. If we run out of room
- SCHEME crashes.
-
- Once the copy is complete we run a full GC which handles the
- broken hearts which now point into pure space. On a
- multiprocessor, this primitive uses the master-gc-loop and it
- should only be used as one would use master-gc-loop i.e. with
- everyone else halted.
-
- This primitive does not return normally. It always escapes into
- the interpreter because some of its cached registers (eg. History)
- have changed.
-*/
-
-Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
-{
- long Saved_Zone;
- Pointer Object, Lost_Objects, Purify_Result, Daemon;
- Primitive_2_Args();
-
- Save_Time_Zone(Zone_Purify);
- if ((Arg2 != TRUTH) && (Arg2 != NIL))
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
-
- /* Pass 1 (Purify, above) does a first copy. Then any GC daemons
- run, and then Purify_Pass_2 is called to copy back.
- */
-
- Touch_In_Primitive(Arg1, Object);
- Purify_Result = Purify(Object, Arg2);
- Pop_Primitive_Frame(2);
- Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
- if (Daemon == NIL)
- {
- Val = Purify_Pass_2(Purify_Result);
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
- /*NOTREACHED*/
- }
- Store_Expression(Purify_Result);
- Store_Return(RC_PURIFY_GC_1);
- Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
- Save_Cont();
- Push(Daemon);
- Push(STACK_FRAME_HEADER);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY); /*NOTREACHED*/
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.28 1987/04/16 02:28:06 jinx Exp $ */
-
-/* Pure/Constant space utilities. */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "gccode.h"
-#include "zones.h"
-\f
-void
-Update(From, To, Was, Will_Be)
- fast Pointer *From, *To, *Was, *Will_Be;
-{
- for (; From < To; From++)
- {
- if (GC_Type_Special(*From))
- {
- if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- continue;
- }
- if (GC_Type_Non_Pointer(*From))
- continue;
- if (Get_Pointer(*From) == Was)
- *From = Make_Pointer(Type_Code(*From), Will_Be);
- }
- return;
-}
-\f
-Pointer
-Make_Impure(Object)
- Pointer Object;
-{
- Pointer *New_Address, *End_Of_Area;
- fast Pointer *Obj_Address, *Constant_Address;
- long Length, Block_Length;
- fast long i;
-
- /* Calculate size of object to be "impurified".
- Note that this depends on the fact that Compiled Entries CANNOT
- be pure.
- */
-
- Switch_by_GC_Type(Object)
- {
- case TC_BROKEN_HEART:
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_Non_Pointer:
- fprintf(stderr, "\nImpurify Non-Pointer.\n");
- Microcode_Termination(TERM_NON_POINTER_RELOCATION);
-
- case TC_BIG_FLONUM:
- case TC_FUTURE:
- case_Vector:
- Length = Vector_Length(Object) + 1;
- break;
-
- case_Quadruple:
- Length = 4;
- break;
-
- case TC_VARIABLE:
- case_Triple:
- Length = 3;
- break;
-
- case TC_WEAK_CONS:
- case_Pair:
- Length = 2;
- break;
-
- case_Cell:
- Length = 1;
- break;
-
- default:
- fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n",
- Type_Code(Object));
- Invalid_Type_Code();
- }
-\f
- /* Add a copy of the object to the last constant block in memory.
- */
-
- Constant_Address = Free_Constant;
-
- Obj_Address = Get_Pointer(Object);
- if (!Test_Pure_Space_Top(Constant_Address + Length))
- return NIL;
- Block_Length = Get_Integer(*(Constant_Address-1));
- Constant_Address -= 2;
- New_Address = Constant_Address;
-
-#ifdef FLOATING_ALIGNMENT
- /* This should be done more cleanly, always align before doing a
- block, or something like it. -- JINX
- */
-
- if (Type_Code(Object) == TC_BIG_FLONUM)
- {
- Pointer *Start;
-
- Start = Constant_Address;
- Align_Float(Constant_Address);
- for (i = 0; i < Length; i++)
- *Constant_Address++ = *Obj_Address++;
- Length = Constant_Address - Start;
- }
- else
-#endif
- for (i = Length; --i >= 0; )
- {
- *Constant_Address++ = *Obj_Address;
- *Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
- }
- *Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length + Length);
- *(New_Address + 2 - Block_Length) =
- Make_Non_Pointer(PURE_PART, Block_Length + Length);
- Obj_Address -= Length;
- Free_Constant = Constant_Address;
-
- /* Run through memory relocating pointers to this object, including
- * those in pure areas.
- */
-
- Set_Pure_Top();
- Terminate_Old_Stacklet();
- Terminate_Constant_Space(End_Of_Area);
- Update(Heap_Bottom, Free, Obj_Address, New_Address);
- Update(Constant_Space, End_Of_Area, Obj_Address, New_Address);
- return Make_Pointer(Type_Code(Object), New_Address);
-}
-\f
-/* (PRIMITIVE-IMPURIFY OBJECT)
- Remove an object from pure space so it can be side effected.
- The object is placed in constant space instead.
-*/
-Built_In_Primitive(Prim_Impurify, 1, "PRIMITIVE-IMPURIFY", 0xBD)
-{
- Pointer Result;
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- Result = Make_Impure(Arg1);
- if (Result != NIL)
- return Result;
- Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE);
- /*NOTREACHED*/
-}
-\f
-Boolean
-Pure_Test(Obj_Address)
- fast Pointer *Obj_Address;
-{
- fast Pointer *Where;
-#ifdef FLOATING_ALIGNMENT
- fast Pointer Float_Align_Value;
-
- Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
-#endif
-
- Where = Free_Constant-1;
- while (Where >= Constant_Space)
- {
-#ifdef FLOATING_ALIGNMENT
- while (*Where == Float_Align_Value)
- Where -= 1;
-#endif
- Where -= 1 + Get_Integer(*Where);
- if (Where <= Obj_Address)
- return
- ((Boolean) (Obj_Address <= (Where + 1 + Get_Integer(*(Where + 1)))));
- }
- return ((Boolean) false);
-}
-\f
-/* (PURE? OBJECT)
- Returns #!TRUE if the object is pure (ie it doesn't point to any
- other object, or it is in a pure section of the constant space).
-*/
-Built_In_Primitive(Prim_Pure_P, 1, "PURE?", 0xBB)
-{
- Primitive_1_Arg();
-
- if ((GC_Type_Non_Pointer(Arg1)) ||
- (GC_Type_Special(Arg1)))
- return TRUTH;
- if (GC_Type_Compiled(Arg1))
- return NIL;
- Touch_In_Primitive(Arg1, Arg1);
- {
- Pointer *Obj_Address;
-
- Obj_Address = Get_Pointer(Arg1);
- if (Is_Pure(Obj_Address))
- return TRUTH;
- }
- return NIL;
-}
-
-/* (CONSTANT? OBJECT)
- Returns #!TRUE if the object is in constant space or isn't a
- pointer.
-*/
-Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?", 0xBA)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- return ((GC_Type_Non_Pointer(Arg1)) ||
- (GC_Type_Special(Arg1)) ||
- ((Get_Pointer(Arg1) >= Constant_Space) &&
- (Get_Pointer(Arg1) < Free_Constant))) ?
- TRUTH : NIL;
-}
-
-/* (GET-NEXT-CONSTANT)
- Returns the next free address in constant space.
-*/
-Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT", 0xE4)
-{
- Pointer *Next_Address;
-
- Next_Address = Free_Constant + 1;
- Primitive_0_Args();
- return Make_Pointer(TC_ADDRESS, Next_Address);
-}
-\f
-/* copy_to_constant_space is a microcode utility procedure.
- It takes care of making legal constant space blocks.
- The microcode kills itself if there is not enough constant
- space left.
- */
-
-extern Pointer *copy_to_constant_space();
-
-Pointer *
-copy_to_constant_space(source, nobjects)
- fast Pointer *source;
- long nobjects;
-{
- fast Pointer *dest;
- fast long i;
- Pointer *result;
-
- dest = Free_Constant;
- if (!Test_Pure_Space_Top(dest + nobjects + 6))
- {
- fprintf(stderr,
- "copy_to_constant_space: Not enough constant space!\n");
- Microcode_Termination(TERM_NO_SPACE);
- }
- *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
- *dest++ = Make_Non_Pointer(PURE_PART, nobjects + 5);
- *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *dest++ = Make_Non_Pointer(CONSTANT_PART, 3);
- result = dest;
- for (i = nobjects; --i >= 0; )
- {
- *dest++ = *source++;
- }
- *dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects + 5);
- Free_Constant = dest;
-
- return result;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $
- *
- * Return codes. These are placed in Return when an
- * interpreter operation needs to operate in several
- * phases. This must correspond with UTABMD.SCM
- *
- */
-\f
-/* These names are also in storage.c.
- * Please maintain consistency.
- */
-
-#define RC_END_OF_COMPUTATION 0x00
-/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
-#define RC_JOIN_STACKLETS 0x01
-#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
-#define RC_INTERNAL_APPLY 0x03
-#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
-#define RC_RESTORE_HISTORY 0x05
-#define RC_INVOKE_STACK_THREAD 0x06
-#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
-#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
-#define RC_EXECUTE_DEFINITION_FINISH 0x09
-#define RC_EXECUTE_ACCESS_FINISH 0x0A
-#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B
-#define RC_SEQ_2_DO_2 0x0C
-#define RC_SEQ_3_DO_2 0x0D
-#define RC_SEQ_3_DO_3 0x0E
-#define RC_CONDITIONAL_DECIDE 0x0F
-#define RC_DISJUNCTION_DECIDE 0x10
-#define RC_COMB_1_PROCEDURE 0x11
-#define RC_COMB_APPLY_FUNCTION 0x12
-#define RC_COMB_2_FIRST_OPERAND 0x13
-#define RC_COMB_2_PROCEDURE 0x14
-#define RC_COMB_SAVE_VALUE 0x15
-#define RC_PCOMB1_APPLY 0x16
-#define RC_PCOMB2_DO_1 0x17
-#define RC_PCOMB2_APPLY 0x18
-#define RC_PCOMB3_DO_2 0x19
-#define RC_PCOMB3_DO_1 0x1A
-#define RC_PCOMB3_APPLY 0x1B
-\f
-#define RC_SNAP_NEED_THUNK 0x1C
-#define RC_REENTER_COMPILED_CODE 0x1D
-/* formerly RC_GET_CHAR_REPEAT 0x1E */
-#define RC_COMP_REFERENCE_RESTART 0x1F
-#define RC_NORMAL_GC_DONE 0x20
-#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
-#define RC_PURIFY_GC_1 0x22
-#define RC_PURIFY_GC_2 0x23
-#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
-#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
-/* formerly RC_GET_CHAR 0x26 */
-/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
-#define RC_COMP_ASSIGNMENT_RESTART 0x28
-#define RC_POP_FROM_COMPILED_CODE 0x29
-#define RC_RETURN_TRAP_POINT 0x2A
-#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
-#define RC_RESTORE_TO_STATE_POINT 0x2C
-#define RC_MOVE_TO_ADJACENT_POINT 0x2D
-#define RC_RESTORE_VALUE 0x2E
-#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
-
-/* The following are not used in the 68000 implementation */
-
-#define RC_POP_RETURN_ERROR 0x40
-#define RC_EVAL_ERROR 0x41
-#define RC_REPEAT_PRIMITIVE 0x42
-#define RC_COMP_INTERRUPT_RESTART 0x43
-/* formerly RC_COMP_RECURSION_GC 0x44 */
-#define RC_RESTORE_INT_MASK 0x45
-#define RC_HALT 0x46
-#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
-#define RC_REPEAT_DISPATCH 0x48
-#define RC_GC_CHECK 0x49
-#define RC_RESTORE_FLUIDS 0x4A
-#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B
-#define RC_COMP_ACCESS_RESTART 0x4C
-#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
-#define RC_COMP_UNBOUND_P_RESTART 0x4E
-#define RC_COMP_DEFINITION_RESTART 0x4F
-#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
-
-#define MAX_RETURN_CODE 0x50
-
-/* When adding return codes, don't forget to update storage.c too. */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sample.c,v 9.21 1987/01/22 14:31:00 jinx Rel $ */
-\f
-/* This file is intended to help you find out how to write primitives.
- Many concepts needed to write primitives can be found by looking
- at actual primitives in the system. Hence this file will often
- ask you to look at other files that contain system primitives.
-*/
-
-/* Files that contain primitives must have the following includes
- near the top of the file.
-*/
-#include "scheme.h"
-#include "primitive.h"
-
-/* Scheme.h supplies useful macros that are used throughout the
- system, and primitive.h supplies macros that are used in defining
- primitives.
-*/
-
-/* To make a primitive, you must use the macro Define_Primitive
- with three arguments, followed by the body of C source code
- that you want the primitive to execute.
- The three arguments are:
- 1. The name you want to give to this body of code (a C procedure
- name).
- 2. The number of arguments that this scheme primitive should
- receive. Note: currently, this must be a number between
- 0 and 3 inclusive. Hence primitives can currently take no more
- than three arguments.
- 3. A string representing the scheme name that you want to identify
- this primitive with.
-
- The value returned by the body of code following the Define_Primitive
- is the value of the scheme primitive. Note that this must be a
- scheme Pointer object (with type tag and datum field), and not an
- arbitrary C object.
-
- As an example, here is a primitive that takes no arguments and always
- returns NIL (NIL is defined in scheme.h and identical to the scheme
- object #!FALSE. TRUTH is identical to the scheme object #!TRUE
-*/
-
-Define_Primitive(Prim_Return_Nil, 0, "RETURN-NIL")
-{ Primitive_0_Args();
- return NIL;
-}
-
-/* This will create the primitive return-nil and when a new scheme is
- made (with the Makefile properly edited to include this file),
- evaluating (make-primitive-procedure 'return-nil) will return a
- primitive procedure that when called with no arguments, will return
- #!FALSE.
-*/
-
-/* Three macros are available for you to access the arguments to the
- primitives. Primitive_N_Args(), where N is between 0 and 3
- inclusive binds Arg1 through ArgN to the arguments passed to the
- primitive. They may also do some other initialization, so unless
- you REALLY know what you are doing, you should use them in your
- code. An important thing to note is that since Primitive_N_Args
- may allocate variables, its use MUST come before any code in the
- body of the C procedure. For example, here is a primitive that
- takes one argument and returns it.
-*/
-
-Define_Primitive(Prim_Identity, 1, "IDENTITY")
-{ Primitive_1_Arg();
- return Arg1;
-}
-
-/* Some primitives may have to allocate space on the heap in order
- to return lists or vectors. There are two things of importance to
- note here. First, the primitive is responsible for making sure
- that there is enough space on the heap for the new structure that
- is being made. For instance, in making a PAIR, two words on the
- heap are used, one to point to the CAR, one for CDR. The macro
- Primitive_GC_If_Needed is supplied to let you check if there is
- room on the heap. Primitive_GC_If_Needed takes one argument which
- is the amount of space you would like to allocate. If there is not
- enough space on the heap, a garbage collection happens and
- afterwards the primitive is restarted with the same arguments. The
- second thing to notice is that the primitive is responsible for
- updating Free according to how many words of storage it has used
- up. Note that the primitive is restarted, not continued, thus any
- side effects must be done after the heap overflow check since
- otherwise they would be done twice.
-
- A pair is object which has a type TC_LIST and points to the first
- element of the pair. The macro Make_Pointer takes a type code and
- an address or data and returns a scheme object with that type code
- and that address or data. See scheme.h and the files included
- there for the possible type codes. The following is the equivalent
- of CONS and takes two arguments and returns the pair which contains
- both arguments. For further examples on heap allocation, see the
- primitives in list.c, hunk.c and vector.c.
-*/
-
-Define_Primitive(Prim_New_Cons, 2, "NEW-CONS")
-{ Pointer *Temp;
- Primitive_2_Args();
- /* Check to see if there is room in the heap for the pair */
- Primitive_GC_If_Needed(2);
- /* Store the values in the heap, updating Free as we go along */
- Temp = Free;
- Free += 2;
- Temp[CONS_CAR] = Arg1;
- Temp[CONS_CDR] = Arg2;
- /* Return the pair, which points to the location of the car */
- return Make_Pointer(TC_LIST, Temp);
-}
-
-/* The following primitive takes three arguments and returns a list
- of them. Note how the CDR of the first two pairs points
- to the next pair. Also, scheme objects are of type Pointer
- (defined in object.h). Note that the result returned can be
- held in a temporary variable even before the contents of the
- object are stored in heap.
-*/
-
-Define_Primitive(Prim_Utterly_Random, 3, "WHY-SHOULDNT-THE-NAME-BE-RANDOM?")
-{ /* Hold the end result in a temporary variable while we
- fill in the list.
- */
- Pointer *Result;
- Primitive_3_Args();
- /* Check to see if there is enough space on the heap. */
- Primitive_GC_If_Needed(6);
- Result = Free;
- Free[CONS_CAR] = Arg1;
- /* Make the CDR of the first pair point to the second pair. */
- Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2);
- /* Bump it over to the second pair */
- Free += 2;
- Free[CONS_CAR] = Arg2;
- /* Make the CDR of the second pair point to the third pair. */
- Free[CONS_CDR] = Make_Pointer(TC_LIST, Free+2);
- /* Bump it over to the third pair */
- Free += 2;
- Free[CONS_CAR] = Arg3;
- /* Make the last CDR a () to make a "proper" list */
- Free[CONS_CDR] = NIL;
- /* Bump Free over to the first available location */
- Free += 2;
- return Make_Pointer(TC_LIST, Result);
-}
-
-/* Several Macros are supplied to do arithmetic with scheme numbers.
- Scheme_Integer_To_C_Integer takes a scheme object and the address
- of a long. If the scheme object is not of type TC_FIXNUM or
- TC_BIG_FIXNUM, then the macro returns ERR_ARG_1_WRONG_TYPE. If the
- scheme number doesn't fit into a long, the macro returns
- ERR_ARG_1_BAD_RANGE. Otherwise the macro stores the integer
- represented by the scheme object into the long.
- C_Integer_To_Scheme_Integer takes a long and returns a scheme
- object of type either TC_FIXNUM or TC_BIG_FIXNUM that represents
- that long. Here is a primitive that tries to add 3 to it's
- argument. Note how scheme errors are performed via
- Primitive_Error({error-code}). See scheme.h and included files for
- the possible error codes.
-*/
-
-Define_Primitive(Prim_Add_3, 1, "3+")
-{ long value;
- int flag;
- Primitive_1_Arg();
- flag = Scheme_Integer_To_C_Integer(Arg1, &value);
- if (flag == PRIM_DONE)
- return C_Integer_To_Scheme_Integer(value + 3);
- /* If flag is not equal to PRIM_DONE, then it is one of two
- errors. We can signal either error by calling Primitive_Error
- with that error code
- */
- Primitive_Error(flag);
-}
-
-/* See fixnum.c for more fixnum primitive examples. float.c
- gives floating point examples and bignum.c gives bignum
- examples (Warning: the bignum code is not trivial). generic.c
- gives examples on arithmetic operations that work for
- all scheme number types. For efficiency reasons, they do not
- always use this convenient interface.
- */
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.23 1987/04/16 02:28:57 jinx Exp $
- *
- * General declarations for the SCode interpreter. This
- * file is INCLUDED by others and contains declarations only.
- */
-\f
-/* Certain debuggers cannot really deal with variables in registers.
- When debugging, NO_REGISTERS can be defined.
-*/
-
-#ifdef NO_REGISTERS
-#define fast
-#else
-#define fast register
-#endif
-
-#define quick fast
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Consistency_Check true
-#else
-#define Consistency_Check false
-#endif
-
-#ifdef COMPILE_STEPPER
-#define Microcode_Does_Stepping true
-#else
-#define Microcode_Does_Stepping false
-#endif
-
-#define forward extern /* For forward references */
-\f
-#include <setjmp.h>
-#include <stdio.h>
-
-#include "config.h" /* Machine and OS configuration info */
-#include "types.h" /* Type code numbers */
-#include "const.h" /* Various named constants */
-#include "object.h" /* Scheme object representation */
-#include "gc.h" /* Garbage collector related macros */
-#include "scode.h" /* Scheme scode representation */
-#include "sdata.h" /* Scheme user data representation */
-#include "futures.h" /* Support macros, etc. for FUTURE */
-#include "errors.h" /* Error code numbers */
-#include "returns.h" /* Return code numbers */
-#include "fixobj.h" /* Format of fixed objects vector */
-#include "stack.h" /* Macros for stack (stacklet) manipulation */
-#include "history.h" /* History maintenance */
-#include "interpret.h" /* Macros for interpreter */
-
-#ifdef butterfly
-#include "butterfly.h"
-#endif
-
-#include "bkpt.h" /* Shadows some defaults */
-#include "default.h" /* Defaults for various hooks. */
-#include "extern.h" /* External declarations */
-#include "prim.h" /* Declarations for external primitives. */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scode.h,v 9.22 1987/04/03 00:20:19 jinx Rel $
- *
- * Format of the SCode representation of programs. Each of these
- * is described in terms of the slots in the data structure.
- *
- */
-\f
-/* Here are the definitions of the the executable operations for the
- interpreter. This file should parallel the file SCODE.SCM in the
- runtime system. The interpreter dispatches on the type code of a
- pointer to determine what operation to perform. The format of the
- storage block this points to is described below. Offsets are the
- number of cells from the location pointed to by the operation. */
-
-/* ALPHABETICALLY LISTED BY TYPE CODE NAME */
-
-/* ACCESS operation: */
-#define ACCESS_ENVIRONMENT 0
-#define ACCESS_NAME 1
-
-/* ASSIGNMENT operation: */
-#define ASSIGN_NAME 0
-#define ASSIGN_VALUE 1
-
-/* COMBINATIONS come in several formats */
-
-/* General combinations are vector-like: */
-#define COMB_VECTOR_HEADER 0
-#define COMB_FN_SLOT 1
-#define COMB_ARG_1_SLOT 2
-
-/* Short non-primitive combinations: */
-#define COMB_1_FN 0
-#define COMB_1_ARG_1 1
-
-#define COMB_2_FN 0
-#define COMB_2_ARG_1 1
-#define COMB_2_ARG_2 2
-
-/* COMMENT operation: */
-#define COMMENT_EXPRESSION 0
-#define COMMENT_TEXT 1
-
-/* CONDITIONAL operation (used for COND, IF, AND): */
-#define COND_PREDICATE 0
-#define COND_CONSEQUENT 1
-#define COND_ALTERNATIVE 2
-\f
-/* DEFINITION operation: */
-#define DEFINE_NAME 0
-#define DEFINE_VALUE 1
-
-/* DELAY operation: */
-#define DELAY_OBJECT 0
-#define DELAY_UNUSED 1
-
-/* DISJUNCTION or OR operation: */
-#define OR_PREDICATE 0
-#define OR_ALTERNATIVE 1
-
-/* EXTENDED_LAMBDA operation:
- * Support for optional parameters and auxiliary local variables. The
- * Extended Lambda is similar to LAMBDA, except that it has an extra
- * word called the ARG_COUNT. This contains an 8-bit count of the
- * number of optional arguments, an 8-bit count of the number of
- * required (formal) parameters, and a bit to indicate that additional
- * (rest) arguments are allowed. The vector of argument names
- * contains, of course, a size count which allows the calculation of
- * the number of auxiliary variables required. Auxiliary variables
- * are created for any internal DEFINEs which are found at syntax time
- * in the body of a LAMBDA-like special form.
- */
-
-#define ELAMBDA_SCODE 0
-#define ELAMBDA_NAMES 1
-#define ELAMBDA_ARG_COUNT 2
-
-/* Masks. The infomation on the number of each type of argument is
- * separated at byte boundaries for easy extraction in the 68000 code.
- */
-
-#define EL_OPTS_MASK 0xFF
-#define EL_FORMALS_MASK 0xFF00
-#define EL_REST_MASK 0x10000
-#define EL_FORMALS_SHIFT 8
-#define EL_REST_SHIFT 16
-
-/* Selectors */
-
-#define Get_Body_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_SCODE))
-#define Get_Names_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_NAMES))
-#define Get_Count_Elambda(Addr) (Fast_Vector_Ref(Addr, ELAMBDA_ARG_COUNT))
-#define Elambda_Formals_Count(Addr) \
- ((((long) Addr) & EL_FORMALS_MASK) >> EL_FORMALS_SHIFT)
-#define Elambda_Opts_Count(Addr) \
- (((long) Addr) & EL_OPTS_MASK)
-#define Elambda_Rest_Flag(Addr) \
- ((((long) Addr) & EL_REST_MASK) >> EL_REST_SHIFT)
-\f
-/* IN-PACKAGE operation: */
-#define IN_PACKAGE_ENVIRONMENT 0
-#define IN_PACKAGE_EXPRESSION 1
-
-/* LAMBDA operation:
- * Object representing a LAMBDA expression with a fixed number of
- * arguments. It consists of a list of the names of the arguments
- * (the first is the name by which the procedure refers to itself) and
- * the SCode for the procedure.
- */
-
-#define LAMBDA_SCODE 0
-#define LAMBDA_FORMALS 1
-
-/* LEXPR
- * Same as LAMBDA (q.v.) except additional arguments are permitted
- * beyond those indicated in the LAMBDA_FORMALS list.
- */
-
-/* Primitive combinations with 0 arguments are not pointers */
-
-/* Primitive combinations, 1 argument: */
-#define PCOMB1_FN_SLOT 0
-#define PCOMB1_ARG_SLOT 1
-
-/* Primitive combinations, 2 arguments: */
-#define PCOMB2_FN_SLOT 0
-#define PCOMB2_ARG_1_SLOT 1
-#define PCOMB2_ARG_2_SLOT 2
-
-/* Primitive combinations, 3 arguments are vector-like: */
-#define PCOMB3_FN_SLOT 1
-#define PCOMB3_ARG_1_SLOT 2
-#define PCOMB3_ARG_2_SLOT 3
-#define PCOMB3_ARG_3_SLOT 4
-
-/* SCODE_QUOTE returns itself */
-#define SCODE_QUOTE_OBJECT 0
-#define SCODE_QUOTE_IGNORED 1
-
-/* SEQUENCE operations (two forms: SEQUENCE_2 and SEQUENCE_3) */
-#define SEQUENCE_1 0
-#define SEQUENCE_2 1
-#define SEQUENCE_3 2
-\f
-/* VARIABLE operation.
- * Corresponds to a variable lookup or variable reference. Contains the
- * symbol referenced, and (if it has been compiled) the frame and
- * offset in the frame in which it was found. One of these cells is
- * multiplexed by having its type code indicate one of several modes
- * of reference: not yet compiled, local reference, formal reference,
- * auxiliary reference, or global value reference.
- * There are extra definitions in lookup.h.
- */
-#define VARIABLE_SYMBOL 0
-#define VARIABLE_FRAME_NO 1
-#define VARIABLE_OFFSET 2
-#define VARIABLE_COMPILED_TYPE 1
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.23 1987/04/16 02:29:06 jinx Exp $
- *
- * Description of the user data objects. This should parallel the
- * file SDATA.SCM in the runtime system.
- *
- */
-\f
-/* Alphabetical order. Every type of object is described either with a
- comment or with offsets describing locations of various parts. */
-
-/* ADDRESS
- * is a FIXNUM. It represents a 24-bit address. Not a pointer type.
- */
-
-/* BIG_FIXNUM (bignum).
- * See the file BIGNUM.C
- */
-
-/* BIG_FLONUM (flonum).
- * Implementation dependent format (uses C data type "double"). Pointer
- * to implemetation defined floating point format.
- */
-
-/* BROKEN_HEART.
- * "Forwarding address" used by garbage collector to indicate that an
- * object has been moved to a new location. These should never be
- * encountered by the interpreter!
- */
-
-/* CELL.
- * An object that points to one other object (extra indirection).
- * Used by the compiler to share objects.
- */
-#define CELL_CONTENTS 0
-
-/* CHARACTER
- * Not currently used. Intended ultimately to complete the abstraction
- * of strings. This will probably be removed eventually.
- */
-
-/* CHARACTER_STRING
- * Synonym for 8B_VECTOR. Used to store strings of characters. Format
- * consists of the normal non-marked vector header (STRING_HEADER)
- * followed by the number of characters in the string (as a FIXNUM),
- * followed by the characters themselves.
- */
-#define STRING_HEADER 0
-#define STRING_LENGTH 1
-#define STRING_CHARS 2
-\f
-/* COMPILED_PROCEDURE */
-#define COMP_PROCEDURE_ADDRESS 0
-#define COMP_PROCEDURE_ENV 1
-
-/* CONTINUATION
- * Pushed on the control stack by the interpreter, each has two parts:
- * the return address within the interpreter (represented as a type
- * code RETURN_ADDRESS and address part RC_xxx), and an expression
- * which was being evaluated at that time (sometimes just used as
- * additional data needed at the return point). The offsets given
- * here are with respect to the stack pointer as it is located
- * immediately after pushing a continuation (or, of course,
- * immediately before popping it back).
- *
- * HISTORY_SIZE is the size of a RESTORE_HISTORY (or
- * RESTORE_DONT_COPY_HISTORY) continuation.
- */
-
-#define CONTINUATION_EXPRESSION 1
-#define CONTINUATION_RETURN_CODE 0
-#define CONTINUATION_SIZE 2
-#define HISTORY_SIZE (CONTINUATION_SIZE + 2)
-\f
-/* CONTROL_POINT
- * Points to a copy of the control stack at the time a control point is
- * created. This is the saved state of the interpreter, and can be
- * restored later by APPLYing the control point to an argument (i.e. a
- * throw). Format is that of an ordinary vector. They are linked
- * together by using the return code RC_JOIN_STACKLETS.
- */
-
-/* If USE_STACKLETS is defined, then a stack (i.e. control point) is
- actually made from smaller units allocated from the heap and linked
- together. The format is:
-
- 0 memory address
-
- _______________________________________
- |MAN. VECT.| n |
- _ _______________________________________
- / | NM VECT | m at GC or when full |
- | _______________________________________
- | | ... |\
- | | not yet in use -- garbage | > m
- n < _______________________________________/
- | | Top of Stack, useful contents | <---Stack_Pointer
- | _______________________________________
- \ | ... |
- \ | useful stuff |
- \_ ________________________________________
- <---Stack_Top
- infinite memory address
-
-*/
-
-#define STACKLET_LENGTH 0 /* = VECTOR_LENGTH */
-#define STACKLET_HEADER_SIZE 2
-#define STACKLET_UNUSED_LENGTH 1
-#define STACKLET_FREE_LIST_LINK 1 /* If on free list */
-\f
-/* DELAYED
- * The object returned by a DELAY operation. Consists initially of a
- * procedure to be APPLYed and environment. After the FORCE primitive
- * is applied to the object, the result is stored in the DELAYED object
- * and further FORCEs return this same result. I.e. FORCE memoizes the
- * value of the DELAYED object. For historical reasons, such an object
- * is called a 'thunk.'
- */
-#define THUNK_SNAPPED 0
-#define THUNK_VALUE 1
-#define THUNK_ENVIRONMENT 0
-#define THUNK_PROCEDURE 1
-
-/* ENVIRONMENT
- * Associates identifiers with values.
- * The identifiers are either from a lambda-binding (as in a procedure
- * call) or a incremental (run-time) DEFINE (known as an 'auxilliary'
- * binding).
- * When an environment frame is created, it only contains lambda
- * bindings. If incremental defines are performed in it or its
- * children, it acquires an extension which contains a list of the
- * auxiliary bindings. Some of these bindings are fictitious in that
- * their only purpose is to make the real bindings (if and when they
- * occur) become automatically dangerous. Bindings become dangerous
- * when they are shadowed by incremental bindings in children frames.
- * Besides the lambda bindings, an environment frame contains a
- * pointer to the procedure which created it. It is through this
- * procedure that the parent frame is found.
- *
- * An environment frame has three distinct stages in its formation:
- * - A STACK_COMBINATION is the structure built on the stack to
- * evaluate normal (long) combinations. It contains a slot for the
- * finger and the combination whose operands are being evaluated.
- * Only some of the argument slots in a stack-combination are
- * meaningful: those which have already been evaluated (those not
- * "hidden" by the finger). This is the first stage.
- * - A STACK_ENVIRONMENT is the format used at Internal_Apply
- * just as an application is about to occur.
- * - An ENVIRONMENT is a real environment frame, containing
- * associations between names and values. It is the final stage, and
- * corresponds to the structure described above.
- */
-\f
-#define ENVIRONMENT_HEADER 0
-#define ENVIRONMENT_FUNCTION 1
-#define ENVIRONMENT_FIRST_ARG 2
-
-#define STACK_ENV_EXTRA_SLOTS 1
-#define STACK_ENV_HEADER 0
-#define STACK_ENV_FUNCTION 1
-#define STACK_ENV_FIRST_ARG 2
-
-#define STACK_COMB_FINGER 0
-#define STACK_COMB_FIRST_ARG 1
-
-/* An environment chain always ends in a pointer with type code
- of GLOBAL_ENV. This will contain an address part which
- either indicates that the lookup should continue on to the
- true global environment, or terminate at this frame. */
-
-#define GO_TO_GLOBAL 0
-#define END_OF_CHAIN 1
-
-/* Environment extension objects:
-
- These objects replace the procedure in environment frames when an
- aux slot is desired. The parent frame is copied into the extension
- so that the "compiled" lookup code does not have to check whether
- the frame has been extended or not.
-
- Note that for the code to work, ENV_EXTENSION_PARENT_FRAME must be
- equal to PROCEDURE_ENVIRONMENT.
-
- The following constants are implicitely hard-coded in lookup.c,
- where a new extension object is consed in extend_frame.
- */
-
-#define ENV_EXTENSION_HEADER 0
-#define ENV_EXTENSION_PARENT_FRAME 1
-#define ENV_EXTENSION_PROCEDURE 2
-#define ENV_EXTENSION_COUNT 3
-#define ENV_EXTENSION_MIN_SIZE 4
-\f
-/* EXTENDED_FIXNUM
- * Not used in the C version. On the 68000 this is used for 24-bit
- * integers, while FIXNUM is used for 16-bit integers.
- */
-
-/* EXTENDED_PROCEDURE
- * Type of procedure created by evaluation of EXTENDED_LAMBDA.
- * It's fields are the same as those for PROCEDURE.
- */
-
-/* FALSE
- * Alternate name for NULL. This is the type code of objects which are
- * considered as false for the value of predicates.
- */
-
-/* FIXNUM
- * Small integer. Fits in the datum portion of a Scheme Pointer.
- */
-
-/* HUNK3
- * User object like a CONS, but with 3 slots rather than 2.
- */
-#define HUNK_CXR0 0
-#define HUNK_CXR1 1
-#define HUNK_CXR2 2
-
-/* INTERNED_SYMBOL
- * A symbol, such as the result of evaluating (QUOTE A). Some
- * important properties of symbols are that they have a print name,
- * and may be 'interned' so that all instances of a symbol with the
- * same name share a unique object. The storage pointed to by a
- * symbol includes both the print name (a string) and the value cell
- * associated with a variable of that name in the global environment.
- */
-#define SYMBOL_NAME 0
-#define SYMBOL_GLOBAL_VALUE 1
-
-/* LIST
- * Ordinary CONS cell as supplied to a user. Perhaps this data type is
- * misnamed ... CONS or PAIR would be better.
- */
-#define CONS_CAR 0
-#define CONS_CDR 1
-
-/* MANIFEST_NM_VECTOR
- * Not a true object, this type code is used to indicate the start of a
- * vector which contains objects other than Scheme pointers. The
- * address portion indicates the number of cells of non-pointers
- * which follow the header word. For use primarily in garbage
- * collection to indicate the number of words to copy but not trace.
- */
-\f
-/* MANIFEST_SPECIAL_NM_VECTOR Similar to MANIFEST_NM_VECTOR but the
- * contents are relocated when loaded by the FALOADer. This header
- * occurs in pure and constant space to indicate the start of a region
- * which contains Pointers to addresses which are known never to move in
- * the operation of the system.
- */
-
-/* MANIFEST_VECTOR
- * Synonym for NULL, used as first cell in a vector object to indicate
- * how many cells it occupies. Usage is similar to MANIFEST_NM_VECTOR
- */
-
-/* NON_MARKED_VECTOR
- * User-visible object containing arbitrary bits. Not currently used.
- * The data portion will always point to a MANIFEST_NM_VECTOR or
- * MANIFEST_SPECIAL_NM_VECTOR specifying the length of the vector.
- */
-#define NM_VECTOR_HEADER 0
-#define NM_ENTRY_COUNT 1
-#define NM_DATA 2
-#define NM_HEADER_LENGTH 2
-
-/* NULL
- * The type code used by predicates to test for 'false' and by list
- * operations for testing for the end of a list.
- */
-
-/* PRIMITIVE
- * The data portion contains a number specifying a particular primitive
- * operation to be performed. An object of type PRIMITIVE can be
- * APPLYed in the same way an object of type PROCEDURE can be.
- */
-
-/* PRIMITIVE_EXTERNAL
- * Functionally identical to PRIMITIVE. The distinctions are that a
- * PRIMITIVE is constrained to take no more than 3 arguments, PRIMITIVEs
- * can be formed into more efficient PRIMITIVE-COMBINATIONs by a
- * compiler, and that PRIMITIVE_EXTERNALs are user supplied.
- */
-
-/* PROCEDURE (formerly CLOSURE)
- * Consists of two parts: a LAMBDA expression and the environment
- * in which the LAMBDA was evaluated to yield the PROCEDURE.
- */
-#define PROCEDURE_LAMBDA_EXPR 0
-#define PROCEDURE_ENVIRONMENT 1
-\f
-/* REFERENCE_TRAP
- * Causes the variable lookup code to trap.
- * Used to implement a variety of features.
- * This type code is really the collection of two, done this way for efficiency.
- * Traps whose datum is less than TRAP_MAX_IMMEDIATE are immediate (not pointers).
- * The rest are pairs. The garbage collector deals with them specially.
- */
-
-#define TRAP_TAG 0
-#define TRAP_EXTRA 1
-
-/* RETURN_CODE
- * Represents an address where computation is to continue. These can be
- * thought of as states in a finite state machine, labels in an assembly
- * language program, or continuations in a formal semantics. When the
- * interpretation of a single SCode item requires the EVALuation of a
- * subproblem, a RETURN_CODE is left behind indicating where computation
- * continues after the evaluation.
- */
-
-/* STATE_POINT and STATE_SPACE
- * Data structures used to keep track of dynamic wind state. Both of
- * these are actually ordinary vectors with a special tag in the first
- * user accessible slot. A STATE_SPACE consists of just a pointer to
- * the current point in that space. A STATE_POINT contains a
- * procedure to be used when moving through the point (the forward
- * thunk), an alternate procedure to undo the effects of the first
- * (the backward thunk), and the point to which you can move directly
- * from this point.
- */
-
-#define STATE_POINT_HEADER 0
-#define STATE_POINT_TAG 1
-#define STATE_POINT_BEFORE_THUNK 2
-#define STATE_POINT_AFTER_THUNK 3
-#define STATE_POINT_NEARER_POINT 4
-#define STATE_POINT_DISTANCE_TO_ROOT 5
-#define STATE_POINT_SIZE 6
-
-#define STATE_SPACE_HEADER 0
-#define STATE_SPACE_TAG 1
-#define STATE_SPACE_NEAREST_POINT 2
-#define STATE_SPACE_SIZE 3
-
-/* When in RC_MOVE_TO_ADJACENT_POINT in the interpreter, the following
- information is available on the stack (placed there by
- Translate_To_Point
-*/
-#define TRANSLATE_FROM_POINT 0
-#define TRANSLATE_FROM_DISTANCE 1
-#define TRANSLATE_TO_POINT 2
-#define TRANSLATE_TO_DISTANCE 3
-\f
-/* TRUE
- * The initial binding of the variable T is to an object of this type.
- * This type is the beginnings of a possible move toward a system where
- * predicates check for TRUE / FALSE rather than not-NULL / NULL.
- */
-
-/* UNINTERNED_SYMBOL
- * This indicates that the object is in the format of an INTERNED_SYMBOL
- * but is not interned.
- */
-
-/* VECTOR
- * A group of contiguous cells with a header (of type MANIFEST_VECTOR)
- * indicating the length of the group.
- */
-#define VECTOR_TYPE 0
-#define VECTOR_LENGTH 0
-#define VECTOR_DATA 1
-
-/* VECTOR_16B
- * Points to a MANIFEST_NM_VECTOR or MANIFEST_SPECIAL_NM_VECTOR header.
- * The format is described under NON_MARKED_VECTOR. The contents are to
- * be treated as an array of 16-bit signed or unsigned quantities. Not
- * currently used, although this may be a useful way to allow users to
- * inspect the internal representation of bignums.
- */
-
-/* VECTOR_1B
- * Similar to VECTOR_16B, but used for a compact representation of an
- * array of booleans.
- */
-
-/* VECTOR_8B
- * An alternate name of CHARACTER_STRING.
- */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.21 1987/04/16 02:29:23 jinx Exp $ */
-
-/* This file contains macros for manipulating stacks and stacklets. */
-\f
-#ifdef USE_STACKLETS
-/* Stack is made up of linked small parts, each in the heap */
-
-#define Initialize_Stack() \
-{ \
- if (GC_Check(Default_Stacklet_Size)) \
- Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \
- Stack_Guard = Free+STACKLET_HEADER_SIZE; \
- *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1); \
- Free += Default_Stacklet_Size; \
- Stack_Pointer = Free; \
- Free_Stacklets = NULL; \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
-}
-
-#define Internal_Will_Push(N) \
-{ \
- if ((Stack_Pointer - (N)) < Stack_Guard) \
- { Export_Registers(); \
- Allocate_New_Stacklet((N)); \
- Import_Registers(); \
- } \
-}
-
-/* No space required independent of the heap for the stacklets */
-
-#define Stack_Allocation_Size(Stack_Blocks) 0
-
-#define Current_Stacklet (Stack_Guard-STACKLET_HEADER_SIZE)
-
-/* Make the unused portion of the old stacklet invisible to garbage
- * collection. This also allows the stack pointer to be reconstructed.
- */
-
-#define Internal_Terminate_Old_Stacklet() \
-{ \
- Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
- Stack_Pointer-Stack_Guard); \
-}
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-
-#define Terminate_Old_Stacklet() \
-{ \
- if (Stack_Pointer < Stack_Guard) \
- { \
- fprintf(stderr, "\nStack_Pointer: 0x%x, Guard: 0x%x\n", \
- Stack_Pointer, Stack_Guard); \
- Microcode_Termination(TERM_EXIT); \
- } \
- Internal_Terminate_Old_Stacklet(); \
-}
-
-#else
-
-#define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet()
-
-#endif
-\f
-/* Used by garbage collector to detect the end of constant space */
-#define Terminate_Constant_Space(Where) \
- *Free_Constant = Make_Pointer(TC_BROKEN_HEART, Free_Constant); \
- Where = Free_Constant
-
-#define Get_Current_Stacklet() \
- Make_Pointer(TC_CONTROL_POINT, Current_Stacklet)
-
-#define Previous_Stack_Pointer(Where) \
- Nth_Vector_Loc(Where, \
- (STACKLET_HEADER_SIZE+ \
- Get_Integer(Vector_Ref(Where, \
- STACKLET_UNUSED_LENGTH))))
-
-#define Set_Current_Stacklet(Where) \
-{ Pointer Our_Where = (Where); \
- Stack_Guard = Nth_Vector_Loc(Our_Where, STACKLET_HEADER_SIZE); \
- Stack_Pointer = Previous_Stack_Pointer(Our_Where); \
-}
-
-#define STACKLET_SLACK STACKLET_HEADER_SIZE + CONTINUATION_SIZE
-#define Default_Stacklet_Size (Stack_Size+STACKLET_SLACK)
-#define New_Stacklet_Size(N) \
- (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1)/Stack_Size))
-
-#define Get_End_Of_Stacklet() \
- (&(Current_Stacklet[1+Get_Integer(*Current_Stacklet)]))
-\f
-#define Apply_Stacklet_Backout() \
-Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Store_Expression(NIL); \
- Store_Return(RC_END_OF_COMPUTATION); \
- Save_Cont(); \
- Push(Val); \
- Push(Previous_Stacklet); \
- Push(STACK_FRAME_HEADER+1); \
- Store_Return(RC_INTERNAL_APPLY); \
- Save_Cont(); \
-Pushed()
-
-#define Join_Stacklet_Backout() Apply_Stacklet_Backout()
-
-/* This depends on the fact that Within_Control_Point is going to
- * push an apply frame immediately after Return_To_Previous_Stacklet
- * "returns". This apply will cause the GC, then the 2nd argument to
- * Within_Control_Point will be invoked, and finally the control point
- * will be entered.
- */
-
-#define Within_Stacklet_Backout() \
-{ Pointer Old_Expression = Fetch_Expression(); \
- Store_Expression(Previous_Stacklet); \
- Store_Return(RC_JOIN_STACKLETS); \
- Save_Cont(); \
- Store_Expression(Old_Expression); \
-}
-\f
-/* Our_Throw is used in chaining from one stacklet
- * to another. In order to improve efficiency, the entire stack is
- * copied neither on catch or throw, but is instead copied one
- * stacklet at a time as needed. The need to copy a stacklet is
- * signified by the danger bit being set in the header of a stacklet.
- * If the danger bit is found to be set in a stacklet which is being
- * returned into then that stacklet is copied and the danger bit is
- * set in the stacklet into which the copied one will return. When a
- * stacklet is returned from it is no longer needed for anything so it
- * can be deallocated. A free list of deallocate stacklets is kept in
- * order to improve the efficiencty of their use.
- */
-
-#define Our_Throw(From_Pop_Return, Stacklet) \
-{ Pointer Previous_Stacklet = (Stacklet); \
- Pointer *Stacklet_Top = Current_Stacklet; \
- Stacklet_Top[STACKLET_FREE_LIST_LINK] = \
- ((Pointer) Free_Stacklets); \
- Free_Stacklets = Stacklet_Top; \
- if (!(From_Pop_Return)) \
- { Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
- } \
- if (!(Dangerous(Fast_Vector_Ref(Previous_Stacklet, \
- STACKLET_UNUSED_LENGTH)))) \
- { if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \
- { Free_Stacklets = \
- ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
- Stack_Pointer = Get_End_Of_Stacklet(); \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0;
-
- /* Backout code inserted here, SUN screw up! */
-\f
- /* Backout code inserted here, SUN screw up! */
-
-#define Our_Throw_Part_2() \
- Request_GC(Vector_Length(Previous_Stacklet) + 1); \
- } \
- else /* Space available for copy */ \
- { long Unused_Length, Used_Length; \
- fast Pointer *Old_Stacklet_Top = \
- Get_Pointer(Previous_Stacklet); \
- Pointer *First_Continuation = \
- Nth_Vector_Loc(Previous_Stacklet, \
- ((1 + Vector_Length(Previous_Stacklet)) - \
- CONTINUATION_SIZE)); \
- if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \
- Prev_Restore_History_Stacklet = NULL; \
- if (First_Continuation[CONTINUATION_RETURN_CODE] == \
- Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
- { Pointer *Even_Older_Stacklet = \
- Get_Pointer(First_Continuation[CONTINUATION_EXPRESSION]);\
- Clear_Danger_Bit(Even_Older_Stacklet[STACKLET_UNUSED_LENGTH]);\
- } \
- Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); \
- Free[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH];\
- Unused_Length = \
- Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \
- STACKLET_HEADER_SIZE; \
- Free += Unused_Length; \
- Stack_Pointer = Free; \
- Used_Length = \
- (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \
- Unused_Length) + 1; \
- Old_Stacklet_Top += Unused_Length; \
- while (--Used_Length >= 0) *Free++ = *Old_Stacklet_Top++; \
- } \
- } \
- else /* No need to copy the stacklet we are going into */ \
- { if (Get_Pointer(Previous_Stacklet)== \
- Prev_Restore_History_Stacklet) \
- Prev_Restore_History_Stacklet = NULL; \
- Set_Current_Stacklet(Previous_Stacklet); \
- } \
-}
-\f
-#else
-
-/* Full size stack in a statically allocated area */
-
-#define Stack_Check(P) \
-{ \
- if ((P) <= Stack_Guard) \
- { if ((P) <= Absolute_Stack_Base) \
- Microcode_Termination (TERM_STACK_OVERFLOW); \
- Request_Interrupt (INT_Stack_Overflow); \
- } \
-}
-
-#define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N))
-
-#define Stack_Allocation_Size(Stack_Blocks) (Stack_Blocks)
-
-#define Terminate_Old_Stacklet()
-
-/* Used by garbage collector to detect the end of constant space, and to
- skip over the gap between constant space and the stack. */
-
-#define Terminate_Constant_Space(Where) \
-{ \
- *Free_Constant = \
- Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, \
- ((Stack_Pointer - Free_Constant) - 1)); \
- *Stack_Top = Make_Pointer (TC_BROKEN_HEART, Stack_Top); \
- Where = Stack_Top; \
-}
-
-#define Get_Current_Stacklet() NIL
-
-#define Set_Current_Stacklet(Where) {}
-
-#define Previous_Stack_Pointer(Where) \
-(Nth_Vector_Loc (Where, \
- (STACKLET_HEADER_SIZE + \
- Get_Integer (Vector_Ref (Where, \
- STACKLET_UNUSED_LENGTH)))))
-
-/* Never allocate more space */
-#define New_Stacklet_Size(N) 0
-
-#define Get_End_Of_Stacklet() Stack_Top
-
-/* Not needed in this version */
-
-#define Join_Stacklet_Backout()
-#define Apply_Stacklet_Backout()
-#define Within_Stacklet_Backout()
-\f
-/* This piece of code KNOWS which way the stack grows.
- The assumption is that successive pushes modify decreasing addresses. */
-
-/* Clear the stack and replace it with a copy of the contents of the
- control point. Also disables the history collection mechanism,
- since the saved history would be incorrect on the new stack. */
-
-#define Our_Throw(From_Pop_Return, P) \
-{ \
- Pointer Control_Point; \
- long NCells, Offset; \
- fast Pointer *To_Where, *From_Where; \
- fast long len; \
- \
- Control_Point = (P); \
- if (Consistency_Check) \
- if (Type_Code (Control_Point) != TC_CONTROL_POINT) \
- Microcode_Termination (TERM_BAD_STACK); \
- len = Vector_Length (Control_Point); \
- NCells = ((len - 1) \
- - Get_Integer (Vector_Ref (Control_Point, \
- STACKLET_UNUSED_LENGTH))); \
- IntCode &= (~ INT_Stack_Overflow); \
- Stack_Check (Stack_Top - NCells); \
- From_Where = Nth_Vector_Loc (Control_Point, STACKLET_HEADER_SIZE); \
- From_Where = Nth_Vector_Loc (Control_Point, ((len + 1) - NCells)); \
- To_Where = (Stack_Top - NCells); \
- Stack_Pointer = To_Where; \
- for (len = 0; len < NCells; len++) \
- *To_Where++ = *From_Where++; \
- if (Consistency_Check) \
- if ((To_Where != Stack_Top) || \
- (From_Where != Nth_Vector_Loc (Control_Point, \
- (1 + Vector_Length (Control_Point))))) \
- Microcode_Termination (TERM_BAD_STACK); \
- if (!(From_Pop_Return)) \
- { \
- Prev_Restore_History_Stacklet = NULL; \
- Prev_Restore_History_Offset = 0; \
- if ((!Valid_Fixed_Obj_Vector ()) || \
- (Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \
- History = Make_Dummy_History (); \
- else \
- History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \
- } \
- else if (Prev_Restore_History_Stacklet == Get_Pointer (Control_Point)) \
- Prev_Restore_History_Stacklet = NULL; \
-}
-
-#define Our_Throw_Part_2()
-
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.22 1987/04/16 02:29:36 jinx Rel $
- *
- * Support for the stepper
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
- /**********************************/
- /* Support of stepping primitives */
- /**********************************/
-
-long Install_Traps(Hunk3, Return_Hook_Too)
-/* UGLY ... this knows (a) that it is called with the primitive frame
- already popped off the stack; and (b) the order in which Save_Cont
- stores things on the stack.
-*/
-Pointer Hunk3;
-Boolean Return_Hook_Too;
-{ Pointer Eval_Hook, Apply_Hook, Return_Hook;
- Stop_Trapping();
- Eval_Hook = Vector_Ref(Hunk3, HUNK_CXR0);
- Apply_Hook = Vector_Ref(Hunk3, HUNK_CXR1);
- Return_Hook = Vector_Ref(Hunk3, HUNK_CXR2);
- Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
- Trapping = (Eval_Hook != NIL) | (Apply_Hook != NIL);
- if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != NIL))
- { /* Here it is ... gross and ugly. We know that the top of stack
- has the existing return code to be clobbered, since it was put
- there by Save_Cont.
- */
- Return_Hook_Address = &Top_Of_Stack();
- Old_Return_Code = Top_Of_Stack();
- *Return_Hook_Address = Make_Non_Pointer(TC_RETURN_CODE,
- RC_RETURN_TRAP_POINT);
- }
-}
-\f
-/* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3)
- Evaluates EXPRESSION in ENV and intalls the eval-trap,
- apply-trap, and return-trap from HUNK3. If any
- trap is '(), it is a null trap that does a normal EVAL,
- APPLY or return.
-*/
-
-Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA)
-{
- Primitive_3_Args();
-
- Install_Traps(Arg3, false);
- Pop_Primitive_Frame(3);
- Store_Expression(Arg1);
- Store_Env(Arg2);
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL);
- /*NOTREACHED*/
-}
-\f
-/* (PRIMITIVE-APPLY-STEP OPERATOR OPERANDS HUNK3)
- Applies OPERATOR to OPERANDS and intalls the eval-trap,
- apply-trap, and return-trap from HUNK3. If any
- trap is '(), it is a null trap that does a normal EVAL,
- APPLY or return.
-
- Mostly a copy of Prim_Apply, since this, too, must count the space
- required before actually building a frame
-*/
-
-Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB)
-{
- Pointer Next_From_Slot, *Next_To_Slot;
- long Number_Of_Args, i;
- Primitive_3_Args();
-
- Arg_3_Type(TC_HUNK3);
- Number_Of_Args = 0;
- Next_From_Slot = Arg2;
- while (Type_Code(Next_From_Slot) == TC_LIST)
- {
- Number_Of_Args += 1;
- Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
- }
- if (Next_From_Slot != NIL)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- Install_Traps(Arg3, true);
- Pop_Primitive_Frame(3);
- Next_From_Slot = Arg2;
- Next_To_Slot = Stack_Pointer - Number_Of_Args;
- Will_Push(Number_Of_Args + STACK_ENV_EXTRA_SLOTS + 1);
- Stack_Pointer = Next_To_Slot;
-
- for (i = 0; i < Number_Of_Args; i++)
- {
- *Next_To_Slot++ = Vector_Ref(Next_From_Slot, CONS_CAR);
- Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
- }
- Push(Arg1); /* The function */
- Push(STACK_FRAME_HEADER + Number_Of_Args);
- Pushed();
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
- /*NOTREACHED*/
-}
-\f
-/* (PRIMITIVE-RETURN-STEP VALUE HUNK3)
- Returns VALUE and intalls the eval-trap, apply-trap, and
- return-trap from HUNK3. If any trap is '(), it is a null trap
- that does a normal EVAL, APPLY or return.
-
- UGLY ... currently assumes that it is illegal to set a return trap
- this way, so that we don't run into stack parsing problems. If
- this is ever changed, be sure to check for COMPILE_STEPPER flag!
-*/
-
-Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC)
-{
- Pointer Return_Hook;
- Primitive_2_Args();
-
- Return_Hook = Vector_Ref(Arg2, HUNK_CXR2);
- if (Return_Hook != NIL)
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Install_Traps(Arg2, false);
- return Arg1;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.28 1987/04/16 02:29:45 jinx Exp $
-
-This file defines the storage for global variables for
-the Scheme Interpreter. */
-
-#include "scheme.h"
-#include "gctype.c"
-\f
- /*************/
- /* REGISTERS */
- /*************/
-
-Pointer
- *Ext_History, /* History register */
- *Free, /* Next free word in storage */
- *MemTop, /* Top of free space available */
- *Ext_Stack_Pointer, /* Next available slot in control stack */
- *Stack_Top, /* Top of control stack */
- *Stack_Guard, /* Guard area at end of stack */
- *Free_Stacklets, /* Free list of stacklets */
- *Constant_Space, /* Bottom of constant+pure space */
- *Free_Constant, /* Next free cell in constant+pure area */
- *Heap_Top, /* Top of current heap */
- *Heap_Bottom, /* Bottom of current heap */
- *Unused_Heap_Top, /* Top of other heap */
- *Unused_Heap, /* Bottom of other heap */
- *Local_Heap_Base, /* Per-processor CONSing area */
- *Heap, /* Bottom of entire heap */
- Current_State_Point = NIL, /* Used by dynamic winder */
- Fluid_Bindings = NIL, /* Fluid bindings AList */
- return_to_interpreter, /* Return address/code left by interpreter
- when calling compiled code */
- *last_return_code, /* Address of the most recent return code in the stack.
- This is only meaningful while in compiled code.
- *** This must be changed when stacklets are used. ***
- */
- Swap_Temp; /* Used by Swap_Pointers in default.h */
-\f
-long IntCode, /* Interrupts requesting */
- IntEnb, /* Interrupts enabled */
- Lookup_Offset, /* Slot lookup result return */
- GC_Reserve = 4500, /* Scheme pointer overflow space in heap */
- GC_Space_Needed, /* Amount of space needed when GC triggered */
- /* Used to signal microcode errors from compiled code. */
- compiled_code_error_code;
-
-Declare_Fixed_Objects();
-
-FILE *(Channels[FILE_CHANNELS]), *File_Handle, *Photo_File_Handle;
-
-int Saved_argc;
-char **Saved_argv;
-char *OS_Name, *OS_Variant;
-
-Boolean Photo_Open = false; /* Photo file open */
-
-Boolean Trapping;
-
-Pointer Old_Return_Code, *Return_Hook_Address;
-
-Pointer *Prev_Restore_History_Stacklet;
-long Prev_Restore_History_Offset;
-
-jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */
-
-long Heap_Size, Constant_Size, Stack_Size;
-Pointer *Highest_Allocated_Address;
-
-#ifndef Heap_In_Low_Memory
-Pointer *Memory_Base;
-#endif
-\f
- /**********************/
- /* DEBUGGING SWITCHES */
- /**********************/
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-Boolean Eval_Debug = false;
-Boolean Hex_Input_Debug = false;
-Boolean File_Load_Debug = false;
-Boolean Reloc_Debug = false;
-Boolean Intern_Debug = false;
-Boolean Cont_Debug = false;
-Boolean Primitive_Debug = false;
-Boolean Lookup_Debug = false;
-Boolean Define_Debug = false;
-Boolean GC_Debug = false;
-Boolean Upgrade_Debug = false;
-Boolean Dump_Debug = false;
-Boolean Trace_On_Error = false;
-Boolean Bignum_Debug = false;
-Boolean Per_File = true;
-Boolean Fluids_Debug = false;
-More_Debug_Flag_Allocs();
-
-int debug_slotno = 0;
-int debug_nslots = 0;
-int local_slotno = 0;
-int local_nslots = 0;
-/* MHWU
-int debug_circle[debug_maxslots];
-int local_circle[debug_maxslots];
-*/
-int debug_circle[100];
-int local_circle[100];
-#endif
-
- /****************************/
- /* Debugging Macro Messages */
- /****************************/
-
-char *CONT_PRINT_RETURN_MESSAGE = "Save_Cont, return code";
-char *CONT_PRINT_EXPR_MESSAGE = "Save_Cont, expression";
-char *RESTORE_CONT_RETURN_MESSAGE = "Restore_Cont, return code";
-char *RESTORE_CONT_EXPR_MESSAGE = "Restore_Cont, expression";
-\f
-static char No_Name[] = "";
-
-char *Return_Names[] = {
-/* 0x00 */ "END_OF_COMPUTATION",
-/* 0x01 */ "JOIN_STACKLETS",
-/* 0x02 */ "RESTORE_CONTINUATION",
-/* 0x03 */ "INTERNAL_APPLY",
-/* 0x04 */ "BAD_INTERRUPT_CONTINUE",
-/* 0x05 */ "RESTORE_HISTORY",
-/* 0x06 */ "INVOKE_STACK_THREAD",
-/* 0x07 */ "RESTART_EXECUTION",
-/* 0x08 */ "EXECUTE_ASSIGNMENT_FINISH",
-/* 0x09 */ "EXECUTE_DEFINITION_FINISH",
-/* 0x0A */ "EXECUTE_ACCESS_FINISH",
-/* 0x0b */ "EXECUTE_IN_PACKAGE_CONTINUE",
-/* 0x0C */ "SEQ_2_DO_2",
-/* 0x0d */ "SEQ_3_DO_2",
-/* 0x0E */ "SEQ_3_DO_3",
-/* 0x0f */ "CONDITIONAL_DECIDE",
-/* 0x10 */ "DISJUNCTION_DECIDE",
-/* 0x11 */ "COMB_1_PROCEDURE",
-/* 0x12 */ "COMB_APPLY_FUNCTION",
-/* 0x13 */ "COMB_2_FIRST_OPERAND",
-/* 0x14 */ "COMB_2_PROCEDURE",
-/* 0x15 */ "COMB_SAVE_VALUE",
-/* 0x16 */ "PCOMB1_APPLY",
-/* 0x17 */ "PCOMB2_DO_1",
-/* 0x18 */ "PCOMB2_APPLY",
-/* 0x19 */ "PCOMB3_DO_2",
-/* 0x1A */ "PCOMB3_DO_1",
-/* 0x1B */ "PCOMB3_APPLY",
-/* 0x1C */ "SNAP_NEED_THUNK",
-/* 0x1D */ No_Name,
-/* 0x1E */ No_Name,
-/* 0x1F */ No_Name,
-/* 0x20 */ "NORMAL_GC_DONE",
-/* 0x21 */ "COMPLETE_GC_DONE",
-/* 0x22 */ "PURIFY_GC_1",
-/* 0x23 */ "PURIFY_GC_2",
-/* 0x24 */ "AFTER_MEMORY_UPDATE",
-/* 0x25 */ "RESTARTABLE_EXIT",
-/* 0x26 */ No_Name,
-/* 0x27 */ No_Name,
-\f
-/* 0x28 */ No_Name,
-/* 0x29 */ No_Name,
-/* 0x2A */ "RETURN_TRAP_POINT",
-/* 0x2B */ "RESTORE_STEPPER",
-/* 0x2C */ "RESTORE_TO_STATE_POINT",
-/* 0x2D */ "MOVE_TO_ADJACENT_POINT",
-/* 0x2E */ "RESTORE_VALUE",
-/* 0x2F */ "RESTORE_DONT_COPY_HISTORY",
-/* 0x30 */ No_Name,
-/* 0x31 */ No_Name,
-/* 0x32 */ No_Name,
-/* 0x33 */ No_Name,
-/* 0x34 */ No_Name,
-/* 0x35 */ No_Name,
-/* 0x36 */ No_Name,
-/* 0x37 */ No_Name,
-/* 0x38 */ No_Name,
-/* 0x39 */ No_Name,
-/* 0x3A */ No_Name,
-/* 0x3B */ No_Name,
-/* 0x3C */ No_Name,
-/* 0x3D */ No_Name,
-/* 0x3E */ No_Name,
-/* 0x3F */ No_Name,
-/* 0x40 */ "POP_RETURN_ERROR",
-/* 0x41 */ "EVAL_ERROR",
-/* 0x42 */ "REPEAT_PRIMITIVE",
-/* 0x43 */ "COMPILER_INTERRUPT_RESTART",
-/* 0x44 */ No_Name,
-/* 0x45 */ "RESTORE_INT_MASK",
-/* 0x46 */ "HALT",
-/* 0x47 */ "FINISH_GLOBAL_INT",
-/* 0x48 */ "REPEAT_DISPATCH",
-/* 0x49 */ "GC_CHECK",
-/* 0x4A */ "RESTORE_FLUIDS",
-/* 0x4B */ "COMPILER_LOOKUP_APPLY_RESTART",
-/* 0x4C */ "COMPILER_ACCESS_RESTART",
-/* 0x4D */ "COMPILER_UNASSIGNED_P_RESTART",
-/* 0x4E */ "COMPILER_UNBOUND_P_RESTART",
-/* 0x4F */ "COMPILER_DEFINITION_RESTART",
-/* 0x50 */ "COMPILER_LEXPR_GC_RESTART"
-};
-
-#if (MAX_RETURN_CODE != 0x50)
-/* Cause an error */
-#include "Returns.h and storage.c are inconsistent -- Names Table"
-#endif
-
-long MAX_RETURN = MAX_RETURN_CODE;
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.23 1987/04/16 02:30:34 jinx Exp $ */
-
-/* String primitives. */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "character.h"
-#include "stringprim.h"
-\f
-/* Currently the strings used in symbols have type codes in the length
- field. They should be changed to have just longwords there. */
-
-Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE", 0x13E)
-{
- long length, count;
- Pointer result;
- Primitive_1_Arg ();
-
- length = (guarantee_nonnegative_int_arg_1 (Arg1));
- /* Add 1 to length to account for '\0' at end of string.
- Add 2 to count to account for string header words. */
- count =
- ((((length + 1) + ((sizeof (Pointer)) - 1))
- / (sizeof (Pointer)))
- + 2);
- Primitive_GC_If_Needed (count);
- result = Make_Pointer (TC_CHARACTER_STRING, Free);
- Free[STRING_HEADER] =
- (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, (count - 1)));
- Free[STRING_LENGTH] = ((long) length);
- *(string_pointer (result, length)) = '\0';
- Free += count;
- return (result);
-}
-
-Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138)
-{
- Primitive_1_Arg ();
-
- return ((string_p (Arg1)) ? TRUTH : NIL);
-}
-\f
-Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139)
-{
- Primitive_1_Arg ();
-
- guarantee_string_arg_1 ();
- return (Make_Unsigned_Fixnum (string_length (Arg1)));
-}
-
-Built_In_Primitive (Prim_String_Maximum_Length, 1,
- "STRING-MAXIMUM-LENGTH", 0x13F)
-{
- Primitive_1_Arg ();
-
- guarantee_string_arg_1 ();
- return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1));
-}
-
-Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140)
-{
- long length, result;
- Primitive_2_Args ();
-
- guarantee_string_arg_1 ();
- length = (guarantee_nonnegative_int_arg_2 (Arg2));
- if (length > (maximum_string_length (Arg1)))
- error_bad_range_arg_2 ();
-
- result = (string_length (Arg1));
- set_string_length (Arg1, length);
- return (Make_Unsigned_Fixnum (result));
-}
-
-long
-substring_length_min (start1, end1, start2, end2)
- long start1, end1, start2, end2;
-{
- fast long length1, length2;
-
- length1 = (end1 - start1);
- length2 = (end2 - start2);
- return ((length1 < length2) ? length1 : length2);
-}
-\f
-#define string_ref_body(process_result) \
-{ \
- long index; \
- long result; \
- Primitive_2_Args (); \
- \
- guarantee_string_arg_1 (); \
- index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \
- \
- return (process_result (string_ref (Arg1, index))); \
-}
-
-Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF", 0x13A)
- string_ref_body (c_char_to_scheme_char)
-
-Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5)
- string_ref_body (Make_Unsigned_Fixnum)
-
-#define string_set_body(get_ascii, process_result) \
-{ \
- long index, ascii; \
- char *char_pointer; \
- Pointer result; \
- Primitive_3_Args (); \
- \
- guarantee_string_arg_1 (); \
- index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \
- ascii = (get_ascii (Arg3)); \
- \
- char_pointer = (string_pointer (Arg1, index)); \
- result = (char_to_long (*char_pointer)); \
- *char_pointer = ascii; \
- return (process_result (result)); \
-}
-
-Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B)
- string_set_body (guarantee_ascii_char_arg_3, c_char_to_scheme_char)
-
-Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6)
- string_set_body (guarantee_ascii_integer_arg_3, Make_Unsigned_Fixnum)
-\f
-#define substring_move_prefix() \
- long start1, end1, start2, end2, length; \
- fast char *scan1, *scan2; \
- Primitive_5_Args (); \
- \
- guarantee_string_arg_1 (); \
- start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \
- guarantee_string_arg_4 (); \
- start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \
- \
- if (end1 > (string_length (Arg1))) \
- error_bad_range_arg_2 (); \
- if (start1 > end1) \
- error_bad_range_arg_1 (); \
- length = (end1 - start1); \
- \
- end2 = (start2 + length); \
- if (end2 > (string_length (Arg4))) \
- error_bad_range_arg_3 ();
-
-Built_In_Primitive (Prim_Substring_Move_Right, 5,
- "SUBSTRING-MOVE-RIGHT!", 0x13C)
-{
- substring_move_prefix()
-
- scan1 = (string_pointer (Arg1, end1));
- scan2 = (string_pointer (Arg4, end2));
- while (length-- > 0)
- *--scan2 = *--scan1;
- return (NIL);
-}
-
-Built_In_Primitive (Prim_Substring_Move_Left, 5,
- "SUBSTRING-MOVE-LEFT!", 0x13D)
-{
- substring_move_prefix()
-
- scan1 = (string_pointer (Arg1, start1));
- scan2 = (string_pointer (Arg4, start2));
- while (length-- > 0)
- *scan2++ = *scan1++;
- return (NIL);
-}
-\f
-#define vector_8b_substring_prefix() \
- long start, end, ascii; \
- long length; \
- char *scan; \
- Primitive_4_Args (); \
- \
- guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
- ascii = (guarantee_ascii_integer_arg_4 (Arg4)); \
- \
- if (end > (string_length (Arg1))) \
- error_bad_range_arg_3 (); \
- if (start > end) \
- error_bad_range_arg_2 ();
-
-Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141)
-{
- vector_8b_substring_prefix ();
-
- length = (end - start);
- scan = (string_pointer (Arg1, start));
- while (length-- > 0)
- *scan++ = ascii;
- return (NIL);
-}
-
-Built_In_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
- "VECTOR-8B-FIND-NEXT-CHAR", 0x142)
-{
- vector_8b_substring_prefix ();
-
- scan = (string_pointer (Arg1, start));
- while (start < end)
- {
- if ((char_to_long (*scan++)) == ascii)
- return (Make_Unsigned_Fixnum (start));
- start += 1;
- }
- return (NIL);
-}
-\f
-Built_In_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR", 0x143)
-{
- vector_8b_substring_prefix ();
-
- scan = (string_pointer (Arg1, end));
- while (end-- > start)
- if ((char_to_long (*--scan)) == ascii)
- return (Make_Unsigned_Fixnum (end));
- return (NIL);
-}
-
-Built_In_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
- "VECTOR-8B-FIND-NEXT-CHAR-CI", 0x144)
-{
- char char1;
- vector_8b_substring_prefix ();
-
- scan = (string_pointer (Arg1, start));
- char1 = (char_upcase (ascii));
- while (start < end)
- {
- if ((char_upcase (*scan++)) == char1)
- return (Make_Unsigned_Fixnum( start));
- start += 1;
- }
- return (NIL);
-}
-
-Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR-CI", 0x145)
-{
- char char1;
- vector_8b_substring_prefix ();
-
- scan = (string_pointer (Arg1, end));
- char1 = (char_upcase (ascii));
- while (end-- > start)
- {
- if ((char_upcase (*--scan)) == char1)
- return (Make_Unsigned_Fixnum (end));
- }
- return (NIL);
-}
-\f
-#define substring_find_char_in_set_prefix() \
- long start, end, length; \
- char *char_set, *scan; \
- Primitive_4_Args (); \
- \
- guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
- guarantee_string_arg_4 (); \
- \
- if (end > (string_length (Arg1))) \
- error_bad_range_arg_3 (); \
- if (start > end) \
- error_bad_range_arg_2 (); \
- if ((string_length (Arg4)) != MAX_ASCII) \
- error_bad_range_arg_4 ();
-
-Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4,
- "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146)
-{
- substring_find_char_in_set_prefix ();
-
- char_set = (Scheme_String_To_C_String (Arg4));
- scan = (string_pointer (Arg1, start));
- while (start < end)
- {
- if (char_set[(char_to_long (*scan++))] != '\0')
- return (Make_Unsigned_Fixnum (start));
- start += 1;
- }
- return (NIL);
-}
-
-Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4,
- "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0x147)
-{
- substring_find_char_in_set_prefix ();
-
- char_set = Scheme_String_To_C_String(Arg4);
- scan = (string_pointer (Arg1, end));
- while (end-- > start)
- if (char_set[(char_to_long (*--scan))] != '\0')
- return (Make_Unsigned_Fixnum (end));
- return (NIL);
-}
-\f
-#define substring_compare_prefix(index1, index2) \
- long start1, end1, start2, end2; \
- char *scan1, *scan2; \
- Primitive_6_Args (); \
- \
- guarantee_string_arg_1 (); \
- start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \
- guarantee_string_arg_4 (); \
- start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \
- end2 = (guarantee_nonnegative_int_arg_6 (Arg6)); \
- \
- if (end1 > (string_length (Arg1))) \
- error_bad_range_arg_3 (); \
- if (start1 > end1) \
- error_bad_range_arg_2 (); \
- \
- if (end2 > (string_length (Arg4))) \
- error_bad_range_arg_6 (); \
- if (start2 > end2) \
- error_bad_range_arg_5 (); \
- \
- scan1 = (string_pointer (Arg1, index1)); \
- scan2 = (string_pointer (Arg4, index2));
-
-#define substring_equal_prefix() \
- long length; \
- substring_compare_prefix (start1, start2); \
- \
- length = (end1 - start1); \
- if (length != (end2 - start2)) \
- return (NIL);
-
-Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?", 0x148)
-{
- substring_equal_prefix ();
-
- while (length-- > 0)
- if ((*scan1++) != (*scan2++))
- return (NIL);
- return (TRUTH);
-}
-
-Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?", 0x149)
-{
- substring_equal_prefix ();
-
- while (length-- > 0)
- if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
- return (NIL);
- return (TRUTH);
-}
-\f
-Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?", 0x14A)
-{
- long length, length1, length2;
- substring_compare_prefix (start1, start2);
-
- length1 = (end1 - start1);
- length2 = (end2 - start2);
- length = ((length1 < length2) ? length1 : length2);
-
- while (length-- > 0)
- if ((*scan1++) != (*scan2++))
- return (((scan1[-1]) < (scan2[-1])) ? TRUTH : NIL);
-
- return ((length1 < length2) ? TRUTH : NIL);
-}
-
-#define substring_modification_prefix() \
- long start, end; \
- fast long length; \
- fast char *scan, temp; \
- Primitive_3_Args (); \
- \
- guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
- \
- if (end > (string_length (Arg1))) \
- error_bad_range_arg_3 (); \
- if (start > end) \
- error_bad_range_arg_2 (); \
- \
- length = (end - start); \
- scan = (string_pointer (Arg1, start));
-
-Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!", 0x14B)
-{
- substring_modification_prefix ();
-
- while (length-- > 0)
- { temp = *scan;
- *scan++ = (char_upcase (temp));
- }
- return (NIL);
-}
-
-Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!", 0x14C)
-{
- substring_modification_prefix ();
-
- while (length-- > 0)
- { temp = *scan;
- *scan++ = (char_downcase (temp));
- }
- return (NIL);
-}
-\f
-#define substring_match_prefix(index1, index2) \
- long length, unmatched; \
- substring_compare_prefix (index1, index2); \
- \
- length = (substring_length_min (start1, end1, start2, end2)); \
- unmatched = length;
-
-Built_In_Primitive (Prim_Match_Forward, 6,
- "SUBSTRING-MATCH-FORWARD", 0x14D)
-{
- substring_match_prefix (start1, start2);
-
- while (unmatched-- > 0)
- if ((*scan1++) != (*scan2++))
- return (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- return (Make_Unsigned_Fixnum (length));
-}
-
-Built_In_Primitive (Prim_Match_Forward_Ci, 6,
- "SUBSTRING-MATCH-FORWARD-CI", 0x14F)
-{
- substring_match_prefix (start1, start2);
-
- while (unmatched-- > 0)
- if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
- return (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- return (Make_Unsigned_Fixnum (length));
-}
-
-Built_In_Primitive (Prim_Match_Backward, 6,
- "SUBSTRING-MATCH-BACKWARD", 0x14E)
-{
- substring_match_prefix (end1, end2);
-
- while (unmatched-- > 0)
- if ((*--scan1) != (*--scan2))
- return (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- return (Make_Unsigned_Fixnum (length));
-}
-
-Built_In_Primitive(Prim_Match_Backward_Ci, 6,
- "SUBSTRING-MATCH-BACKWARD-CI", 0x150)
-{
- substring_match_prefix (end1, end2);
-
- while (unmatched-- > 0)
- if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
- return (Make_Unsigned_Fixnum (length - (unmatched + 1)));
- return (Make_Unsigned_Fixnum (length));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.22 1987/04/16 12:21:36 jinx Rel $
- *
- * Random system primitives. Most are implemented in terms of
- * utilities in os.c
- *
- */
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* Interrupt primitives */
-
-Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2,
- "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", 0x107)
-{
- extern Boolean OS_Clean_Interrupt_Channel();
- Primitive_2_Args();
-
- return (OS_Clean_Interrupt_Channel(Get_Integer(Arg1),
- Get_Integer(Arg2)) ?
- TRUTH : NIL);
-}
-
-Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0,
- "GET-NEXT-INTERRUPT-CHARACTER", 0x106)
-{
- int result;
- extern int OS_Get_Next_Interrupt_Character();
- Primitive_0_Args();
-
- result = OS_Get_Next_Interrupt_Character();
- if (result == -1)
- {
- Primitive_Error(ERR_EXTERNAL_RETURN);
- /*NOTREACHED*/
- }
- IntCode &= ~INT_Character;
- return Make_Unsigned_Fixnum(result);
-}
-\f
-/* Time primitives */
-
-Built_In_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK", 0x109)
-{
- Primitive_0_Args();
-
- return Make_Unsigned_Fixnum(System_Clock());
-}
-
-Built_In_Primitive(Prim_Setup_Timer_Interrupt, 2,
- "SETUP-TIMER-INTERRUPT", 0x153)
-{
- extern void Clear_Int_Timer(), Set_Int_Timer();
- Primitive_2_Args();
-
- if ((Arg1 == NIL) && (Arg2==NIL))
- Clear_Int_Timer();
- else
- {
- long Days, Centi_Seconds;
-
- Arg_1_Type(TC_FIXNUM);
- Arg_2_Type(TC_FIXNUM);
- Sign_Extend(Arg1, Days);
- Sign_Extend(Arg2, Centi_Seconds);
- Set_Int_Timer(Days, Centi_Seconds);
- }
- IntCode &= ~INT_Timer;
- return NIL;
-}
-\f
-/* Date and current time primitives */
-
-#define Date_Primitive(OS_Name) \
-{ \
- int result; \
- extern int OS_Name(); \
- Primitive_0_Args(); \
- \
- result = OS_Name(); \
- if (result == -1) \
- return NIL; \
- return Make_Unsigned_Fixnum(result); \
-}
-
-Built_In_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR", 0x126)
-Date_Primitive(OS_Current_Year)
-
-Built_In_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH", 0x127)
-Date_Primitive(OS_Current_Month)
-
-Built_In_Primitive(Prim_Current_Day, 0, "CURRENT-DAY", 0x128)
-Date_Primitive(OS_Current_Day)
-
-Built_In_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR", 0x129)
-Date_Primitive(OS_Current_Hour)
-
-Built_In_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE", 0x12A)
-Date_Primitive(OS_Current_Minute)
-
-Built_In_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND", 0x12B)
-Date_Primitive(OS_Current_Second)
-\f
-/* Pretty random primitives */
-
-/* (EXIT)
- Halt SCHEME, with no intention of restarting.
-*/
-
-Built_In_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT", 0x16)
-{
- Primitive_0_Args();
-
- Microcode_Termination(TERM_HALT);
-}
-
-/* (HALT)
- Halt Scheme in such a way that it can be restarted.
- Not all operating systems support this.
-*/
-Built_In_Primitive(Prim_Restartable_Exit, 0, "HALT", 0x1A)
-{
- extern Boolean Restartable_Exit();
- Primitive_0_Args();
-
- Restartable_Exit();
- return ((Restartable_Exit() ? TRUTH : NIL));
-}
-
-/* (SET-RUN-LIGHT! OBJECT)
- On the HP Pascal workstation system, it allows the character
- displayed in the lower right-hand part of the screen to be changed.
- In CScheme, rings the bell.
- Used by various things to indicate the state of the system.
-*/
-
-Built_In_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!", 0xC0)
-{
- Primitive_1_Arg();
-#ifdef RUN_LIGHT_IS_BEEP
- extern void OS_tty_beep();
-
- OS_tty_beep();
- OS_Flush_Output_Buffer();
- return TRUTH;
-#else
- return NIL;
-#endif
-}
-
-Built_In_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?", 0x1A1)
-{
- extern Boolean OS_Under_Emacs();
- Primitive_0_Args();
-
- return (OS_Under_Emacs() ? TRUTH : NIL);
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */
-\f
-/* Kinds of traps:
-
- Note that for every trap there is a dangerous version.
- The danger bit is the bottom bit of the trap number,
- thus all dangerous traps are odd and viceversa.
-
- For efficiency, some traps are immediate, while some are
- pointer objects. The type code is multiplexed, and the
- garbage collector handles it specially.
-
- */
-
-/* The following are immediate traps: */
-
-#define TRAP_UNASSIGNED 0
-#define TRAP_UNASSIGNED_DANGEROUS 1
-#define TRAP_UNBOUND 2
-#define TRAP_UNBOUND_DANGEROUS 3
-#define TRAP_ILLEGAL 4
-#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */
-
-/* TRAP_MAX_IMMEDIATE is defined in const.h */
-
-/* The following are not: */
-
-#define TRAP_NOP 10 /* Unused. */
-#define TRAP_DANGEROUS 11
-#define TRAP_FLUID 12
-#define TRAP_FLUID_DANGEROUS 13
-
-/* Trap utilities */
-
-#define get_trap_kind(variable, what) \
-{ \
- variable = Datum(what); \
- if (variable > TRAP_MAX_IMMEDIATE) \
- variable = Datum(Vector_Ref(what, TRAP_TAG)); \
-}
-\f
-/* Common constants */
-
-#ifndef b32
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
-#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
-#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
-#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL)
-#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
-#else
-#define UNASSIGNED_OBJECT 0x32000000
-#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001
-#define UNBOUND_OBJECT 0x32000002
-#define DANGEROUS_UNBOUND_OBJECT 0x32000003
-#define ILLEGAL_OBJECT 0x32000004
-#define DANGEROUS_ILLEGAL_OBJECT 0x32000005
-#endif
-
-#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
-
-#if (TC_REFERENCE_TRAP != 0x32)
-#include "error: trap.h and types.h are inconsistent"
-#endif
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $
- *
- * Type code definitions, numerical order
- *
- */
-\f
-#define TC_NULL 0x00
-#define TC_LIST 0x01
-#define TC_CHARACTER 0x02
-#define TC_SCODE_QUOTE 0x03
-#define TC_PCOMB2 0x04
-#define TC_UNINTERNED_SYMBOL 0x05
-#define TC_BIG_FLONUM 0x06
-#define TC_COMBINATION_1 0x07
-#define TC_TRUE 0x08
-#define TC_EXTENDED_PROCEDURE 0x09
-#define TC_VECTOR 0x0A
-#define TC_RETURN_CODE 0x0B
-#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D
-#define TC_BIG_FIXNUM 0x0E
-#define TC_PROCEDURE 0x0F
-#define TC_PRIMITIVE_EXTERNAL 0x10
-#define TC_DELAY 0x11
-#define TC_ENVIRONMENT 0x12
-#define TC_DELAYED 0x13
-#define TC_EXTENDED_LAMBDA 0x14
-#define TC_COMMENT 0x15
-#define TC_NON_MARKED_VECTOR 0x16
-#define TC_LAMBDA 0x17
-#define TC_PRIMITIVE 0x18
-#define TC_SEQUENCE_2 0x19
-\f
-#define TC_FIXNUM 0x1A
-#define TC_PCOMB1 0x1B
-#define TC_CONTROL_POINT 0x1C
-#define TC_INTERNED_SYMBOL 0x1D
-#define TC_CHARACTER_STRING 0x1E
-#define TC_ACCESS 0x1F
-/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */
-#define TC_DEFINITION 0x21
-#define TC_BROKEN_HEART 0x22
-#define TC_ASSIGNMENT 0x23
-#define TC_HUNK3 0x24
-#define TC_IN_PACKAGE 0x25
-#define TC_COMBINATION 0x26
-#define TC_MANIFEST_NM_VECTOR 0x27
-#define TC_COMPILED_EXPRESSION 0x28
-#define TC_LEXPR 0x29
-#define TC_PCOMB3 0x2A
-#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
-#define TC_VARIABLE 0x2C
-#define TC_THE_ENVIRONMENT 0x2D
-#define TC_FUTURE 0x2E
-#define TC_VECTOR_1B 0x2F
-#define TC_PCOMB0 0x30
-#define TC_VECTOR_16B 0x31
-#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */
-#define TC_SEQUENCE_3 0x33
-#define TC_CONDITIONAL 0x34
-#define TC_DISJUNCTION 0x35
-#define TC_CELL 0x36
-#define TC_WEAK_CONS 0x37
-#define TC_QUAD 0x38 /* Used to be TC_TRAP. */
-#define TC_RETURN_ADDRESS 0x39
-#define TC_COMPILER_LINK 0x3A
-#define TC_STACK_ENVIRONMENT 0x3B
-#define TC_COMPLEX 0x3C
-
-/* If you add a new type, don't forget to update gccode.h and gctype.c */
-
-/* Aliases */
-
-#define TC_FALSE TC_NULL
-#define TC_MANIFEST_VECTOR TC_NULL
-#define GLOBAL_ENV TC_NULL
-#define TC_BIT_STRING TC_VECTOR_1B
-#define TC_VECTOR_8B TC_CHARACTER_STRING
-#define TC_ADDRESS TC_FIXNUM
+++ /dev/null
-/* Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
-
-This file is part of GNU Emacs.
-
-GNU Emacs is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY. No author or distributor
-accepts responsibility to anyone for the consequences of using it
-or for whether it serves any particular purpose or works at all,
-unless he says so in writing. Refer to the GNU Emacs General Public
-License for full details.
-
-Everyone is granted permission to copy, modify and redistribute
-GNU Emacs, but only under the conditions described in the
-GNU Emacs General Public License. A copy of this license is
-supposed to have been given to you along with GNU Emacs so you
-can know your rights and responsibilities. It should be in a
-file named COPYING. Among other things, the copyright notice
-and this notice must be preserved on all copies. */
-
-
-/*
- * unexec.c - Convert a running program into an a.out file.
- *
- * Author: Spencer W. Thomas
- * Computer Science Dept.
- * University of Utah
- * Date: Tue Mar 2 1982
- * Modified heavily since then.
- *
- * Synopsis:
- * unexec (new_name, a_name, data_start, bss_start, entry_address)
- * char *new_name, *a_name;
- * unsigned data_start, bss_start, entry_address;
- *
- * Takes a snapshot of the program and makes an a.out format file in the
- * file named by the string argument new_name.
- * If a_name is non-NULL, the symbol table will be taken from the given file.
- * On some machines, an existing a_name file is required.
- *
- * The boundaries within the a.out file may be adjusted with the data_start
- * and bss_start arguments. Either or both may be given as 0 for defaults.
- *
- * Data_start gives the boundary between the text segment and the data
- * segment of the program. The text segment can contain shared, read-only
- * program code and literal data, while the data segment is always unshared
- * and unprotected. Data_start gives the lowest unprotected address.
- * The value you specify may be rounded down to a suitable boundary
- * as required by the machine you are using.
- *
- * Specifying zero for data_start means the boundary between text and data
- * should not be the same as when the program was loaded.
- * If NO_REMAP is defined, the argument data_start is ignored and the
- * segment boundaries are never changed.
- *
- * Bss_start indicates how much of the data segment is to be saved in the
- * a.out file and restored when the program is executed. It gives the lowest
- * unsaved address, and is rounded up to a page boundary. The default when 0
- * is given assumes that the entire data segment is to be stored, including
- * the previous data and bss as well as any additional storage allocated with
- * break (2).
- *
- * The new file is set up to start at entry_address.
- *
- * If you make improvements I'd like to get them too.
- * harpo!utah-cs!thomas, thomas@Utah-20
- *
- */
-
-/* There are several compilation parameters affecting unexec:
-
-* COFF
-
-Define this if your system uses COFF for executables.
-Otherwise we assume you use Berkeley format.
-
-* NO_REMAP
-
-Define this if you do not want to try to save Emacs's pure data areas
-as part of the text segment.
-
-Saving them as text is good because it allows users to share more.
-
-However, on machines that locate the text area far from the data area,
-the boundary cannot feasibly be moved. Such machines require
-NO_REMAP.
-
-Also, remapping can cause trouble with the built-in startup routine
-/lib/crt0.o, which defines `environ' as an initialized variable.
-Dumping `environ' as pure does not work! So, to use remapping,
-you must write a startup routine for your machine in Emacs's crt0.c.
-If NO_REMAP is defined, Emacs uses the system's crt0.o.
-
-* SECTION_ALIGNMENT
-
-Some machines that use COFF executables require that each section
-start on a certain boundary *in the COFF file*. Such machines should
-define SECTION_ALIGNMENT to a mask of the low-order bits that must be
-zero on such a boundary. This mask is used to control padding between
-segments in the COFF file.
-
-If SECTION_ALIGNMENT is not defined, the segments are written
-consecutively with no attempt at alignment. This is right for
-unmodified system V.
-
-* SEGMENT_MASK
-
-Some machines require that the beginnings and ends of segments
-*in core* be on certain boundaries. For most machines, a page
-boundary is sufficient. That is the default. When a larger
-boundary is needed, define SEGMENT_MASK to a mask of
-the bits that must be zero on such a boundary.
-
-* A_TEXT_OFFSET(HDR)
-
-Some machines count the a.out header as part of the size of the text
-segment (a_text); they may actually load the header into core as the
-first data in the text segment. Some have additional padding between
-the header and the real text of the program that is counted in a_text.
-
-For these machines, define A_TEXT_OFFSET(HDR) to examine the header
-structure HDR and return the number of bytes to add to `a_text'
-before writing it (above and beyond the number of bytes of actual
-program text). HDR's standard fields are already correct, except that
-this adjustment to the `a_text' field has not yet been made;
-thus, the amount of offset can depend on the data in the file.
-
-* A_TEXT_SEEK(HDR)
-
-If defined, this macro specifies the number of bytes to seek into the
-a.out file before starting to write the text segment.a
-
-* EXEC_MAGIC
-
-For machines using COFF, this macro, if defined, is a value stored
-into the magic number field of the output file.
-
-* ADJUST_EXEC_HEADER
-
-This macro can be used to generate statements to adjust or
-initialize nonstandard fields in the file header
-
-* ADDR_CORRECT(ADDR)
-
-Macro to correct an int which is the bit pattern of a pointer to a byte
-into an int which is the number of a byte.
-
-This macro has a default definition which is usually right.
-This default definition is a no-op on most machines (where a
-pointer looks like an int) but not on all machines.
-
-*/
-
-#ifndef mips /* mips machine requires completely separate code. */
-
-#ifndef emacs
-#define PERROR(arg) perror (arg); return -1
-#else
-#include "config.h"
-#define PERROR(file) report_error (file, new)
-#endif
-
-#ifndef CANNOT_DUMP /* all rest of file! */
-
-#include <a.out.h>
-/* Define getpagesize () if the system does not.
- Note that this may depend on symbols defined in a.out.h
- */
-#include "getpagesize.h"
-
-#ifndef makedev /* Try to detect types.h already loaded */
-#include <sys/types.h>
-#endif
-#include <stdio.h>
-#include <sys/stat.h>
-#include <errno.h>
-
-extern char *start_of_text (); /* Start of text */
-extern char *start_of_data (); /* Start of initialized data */
-
-#ifdef COFF
-#ifndef USG
-#ifndef STRIDE
-#ifndef UMAX
-/* I have a suspicion that these are turned off on all systems
- and can be deleted. Try it in version 19. */
-#include <filehdr.h>
-#include <aouthdr.h>
-#include <scnhdr.h>
-#include <syms.h>
-#endif /* not UMAX */
-#endif /* Not STRIDE */
-#endif /* not USG */
-static long block_copy_start; /* Old executable start point */
-static struct filehdr f_hdr; /* File header */
-static struct aouthdr f_ohdr; /* Optional file header (a.out) */
-long bias; /* Bias to add for growth */
-long lnnoptr; /* Pointer to line-number info within file */
-#define SYMS_START block_copy_start
-
-static long text_scnptr;
-static long data_scnptr;
-
-#else /* not COFF */
-
-extern char *sbrk ();
-
-#define SYMS_START ((long) N_SYMOFF (ohdr))
-
-#ifdef HPUX
-#ifdef HP9000S200_ID
-#define MY_ID HP9000S200_ID
-#else
-#include <model.h>
-#define MY_ID MYSYS
-#endif /* no HP9000S200_ID */
-static MAGIC OLDMAGIC = {MY_ID, SHARE_MAGIC};
-static MAGIC NEWMAGIC = {MY_ID, DEMAND_MAGIC};
-#define N_TXTOFF(x) TEXT_OFFSET(x)
-#define N_SYMOFF(x) LESYM_OFFSET(x)
-static struct exec hdr, ohdr;
-
-#else /* not HPUX */
-
-#ifdef USG
-static struct bhdr hdr, ohdr;
-#define a_magic fmagic
-#define a_text tsize
-#define a_data dsize
-#define a_bss bsize
-#define a_syms ssize
-#define a_trsize rtsize
-#define a_drsize rdsize
-#define a_entry entry
-#define N_BADMAG(x) \
- (((x).fmagic)!=OMAGIC && ((x).fmagic)!=NMAGIC &&\
- ((x).fmagic)!=FMAGIC && ((x).fmagic)!=IMAGIC)
-#define NEWMAGIC FMAGIC
-#else /* not USG */
-static struct exec hdr, ohdr;
-#define NEWMAGIC ZMAGIC
-#endif /* not USG */
-#endif /* not HPUX */
-
-static int unexec_text_start;
-static int unexec_data_start;
-
-#endif /* not COFF */
-
-static int pagemask;
-
-/* Correct an int which is the bit pattern of a pointer to a byte
- into an int which is the number of a byte.
- This is a no-op on ordinary machines, but not on all. */
-
-#ifndef ADDR_CORRECT /* Let m-*.h files override this definition */
-#define ADDR_CORRECT(x) ((char *)(x) - (char*)0)
-#endif
-
-#ifdef emacs
-
-static
-report_error (file, fd)
- char *file;
- int fd;
-{
- if (fd)
- close (fd);
- error ("Failure operating on %s", file);
-}
-#endif /* emacs */
-
-#define ERROR0(msg) report_error_1 (new, msg, 0, 0); return -1
-#define ERROR1(msg,x) report_error_1 (new, msg, x, 0); return -1
-#define ERROR2(msg,x,y) report_error_1 (new, msg, x, y); return -1
-
-static
-report_error_1 (fd, msg, a1, a2)
- int fd;
- char *msg;
- int a1, a2;
-{
- close (fd);
-#ifdef emacs
- error (msg, a1, a2);
-#else
- fprintf (stderr, msg, a1, a2);
- fprintf (stderr, "\n");
-#endif
-}
-\f
-/* ****************************************************************
- * unexec
- *
- * driving logic.
- */
-unexec (new_name, a_name, data_start, bss_start, entry_address)
- char *new_name, *a_name;
- unsigned data_start, bss_start, entry_address;
-{
- int new, a_out = -1;
-
- if (a_name && (a_out = open (a_name, 0)) < 0)
- {
- PERROR (a_name);
- }
- if ((new = creat (new_name, 0666)) < 0)
- {
- PERROR (new_name);
- }
-
- if (make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name) < 0
- || copy_text_and_data (new) < 0
- || copy_sym (new, a_out, a_name, new_name) < 0
-#ifdef COFF
- || adjust_lnnoptrs (new, a_out, new_name) < 0
-#endif
- )
- {
- close (new);
- /* unlink (new_name); /* Failed, unlink new a.out */
- return -1;
- }
-
- close (new);
- if (a_out >= 0)
- close (a_out);
- mark_x (new_name);
- return 0;
-}
-
-/* ****************************************************************
- * make_hdr
- *
- * Make the header in the new a.out from the header in core.
- * Modify the text and data sizes.
- */
-static int
-make_hdr (new, a_out, data_start, bss_start, entry_address, a_name, new_name)
- int new, a_out;
- unsigned data_start, bss_start, entry_address;
- char *a_name;
- char *new_name;
-{
- int tem;
-#ifdef COFF
- auto struct scnhdr f_thdr; /* Text section header */
- auto struct scnhdr f_dhdr; /* Data section header */
- auto struct scnhdr f_bhdr; /* Bss section header */
- auto struct scnhdr scntemp; /* Temporary section header */
- register int scns;
-#endif /* COFF */
- unsigned int bss_end;
-
- pagemask = getpagesize () - 1;
-
- /* Adjust text/data boundary. */
-#ifdef NO_REMAP
- data_start = (int) start_of_data ();
-#else /* not NO_REMAP */
- if (!data_start)
- data_start = (int) start_of_data ();
-#endif /* not NO_REMAP */
- data_start = ADDR_CORRECT (data_start);
-
-#ifdef SEGMENT_MASK
- data_start = data_start & ~SEGMENT_MASK; /* (Down) to segment boundary. */
-#else
- data_start = data_start & ~pagemask; /* (Down) to page boundary. */
-#endif
-
- bss_end = (ADDR_CORRECT (sbrk (0)) + pagemask) & ~pagemask;
-
- /* Adjust data/bss boundary. */
- if (bss_start != 0)
- {
- bss_start = (ADDR_CORRECT (bss_start) + pagemask) & ~pagemask; /* (Up) to page bdry. */
- if (bss_start > bss_end)
- {
- ERROR1 ("unexec: Specified bss_start (%u) is past end of program",
- bss_start);
- }
- }
- else
- bss_start = bss_end;
-
- if (data_start > bss_start) /* Can't have negative data size. */
- {
- ERROR2 ("unexec: data_start (%u) can't be greater than bss_start (%u)",
- data_start, bss_start);
- }
-
-#ifdef COFF
- /* Salvage as much info from the existing file as possible */
- if (a_out >= 0)
- {
- if (read (a_out, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
- {
- PERROR (a_name);
- }
- block_copy_start += sizeof (f_hdr);
- if (f_hdr.f_opthdr > 0)
- {
- if (read (a_out, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
- {
- PERROR (a_name);
- }
- block_copy_start += sizeof (f_ohdr);
- }
- /* Loop through section headers, copying them in */
- for (scns = f_hdr.f_nscns; scns > 0; scns--) {
- if (read (a_out, &scntemp, sizeof (scntemp)) != sizeof (scntemp))
- {
- PERROR (a_name);
- }
- if (scntemp.s_scnptr > 0L)
- {
- if (block_copy_start < scntemp.s_scnptr + scntemp.s_size)
- block_copy_start = scntemp.s_scnptr + scntemp.s_size;
- }
- if (strcmp (scntemp.s_name, ".text") == 0)
- {
- f_thdr = scntemp;
- }
- else if (strcmp (scntemp.s_name, ".data") == 0)
- {
- f_dhdr = scntemp;
- }
- else if (strcmp (scntemp.s_name, ".bss") == 0)
- {
- f_bhdr = scntemp;
- }
- }
- }
- else
- {
- ERROR0 ("can't build a COFF file from scratch yet");
- }
-
- /* Now we alter the contents of all the f_*hdr variables
- to correspond to what we want to dump. */
-
- f_hdr.f_flags |= (F_RELFLG | F_EXEC);
-#ifdef EXEC_MAGIC
- f_ohdr.magic = EXEC_MAGIC;
-#endif
-#ifndef NO_REMAP
- f_ohdr.text_start = (long) start_of_text ();
- f_ohdr.tsize = data_start - f_ohdr.text_start;
- f_ohdr.data_start = data_start;
-#endif /* NO_REMAP */
- f_ohdr.dsize = bss_start - f_ohdr.data_start;
- f_ohdr.bsize = bss_end - bss_start;
- f_thdr.s_size = f_ohdr.tsize;
- f_thdr.s_scnptr = sizeof (f_hdr) + sizeof (f_ohdr);
- f_thdr.s_scnptr += (f_hdr.f_nscns) * (sizeof (f_thdr));
- lnnoptr = f_thdr.s_lnnoptr;
-#ifdef SECTION_ALIGNMENT
- /* Some systems require special alignment
- of the sections in the file itself. */
- f_thdr.s_scnptr
- = (f_thdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
-#endif /* SECTION_ALIGNMENT */
- text_scnptr = f_thdr.s_scnptr;
- f_dhdr.s_paddr = f_ohdr.data_start;
- f_dhdr.s_vaddr = f_ohdr.data_start;
- f_dhdr.s_size = f_ohdr.dsize;
- f_dhdr.s_scnptr = f_thdr.s_scnptr + f_thdr.s_size;
-#ifdef SECTION_ALIGNMENT
- /* Some systems require special alignment
- of the sections in the file itself. */
- f_dhdr.s_scnptr
- = (f_dhdr.s_scnptr + SECTION_ALIGNMENT) & ~SECTION_ALIGNMENT;
-#endif /* SECTION_ALIGNMENT */
- data_scnptr = f_dhdr.s_scnptr;
- f_bhdr.s_paddr = f_ohdr.data_start + f_ohdr.dsize;
- f_bhdr.s_vaddr = f_ohdr.data_start + f_ohdr.dsize;
- f_bhdr.s_size = f_ohdr.bsize;
- f_bhdr.s_scnptr = 0L;
- bias = f_dhdr.s_scnptr + f_dhdr.s_size - block_copy_start;
-
- if (f_hdr.f_symptr > 0L)
- {
- f_hdr.f_symptr += bias;
- }
-
- if (f_thdr.s_lnnoptr > 0L)
- {
- f_thdr.s_lnnoptr += bias;
- }
-
-#ifdef ADJUST_EXEC_HEADER
- ADJUST_EXEC_HEADER
-#endif /* ADJUST_EXEC_HEADER */
-
- if (write (new, &f_hdr, sizeof (f_hdr)) != sizeof (f_hdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_ohdr, sizeof (f_ohdr)) != sizeof (f_ohdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_thdr, sizeof (f_thdr)) != sizeof (f_thdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_dhdr, sizeof (f_dhdr)) != sizeof (f_dhdr))
- {
- PERROR (new_name);
- }
-
- if (write (new, &f_bhdr, sizeof (f_bhdr)) != sizeof (f_bhdr))
- {
- PERROR (new_name);
- }
- return (0);
-
-#else /* if not COFF */
-
- /* Get symbol table info from header of a.out file if given one. */
- if (a_out >= 0)
- {
- if (read (a_out, &ohdr, sizeof hdr) != sizeof hdr)
- {
- PERROR (a_name);
- }
-
- if N_BADMAG (ohdr)
- {
- ERROR1 ("invalid magic number in %s", a_name);
- }
- hdr = ohdr;
- }
- else
- {
- bzero (hdr, sizeof hdr);
- }
-
- unexec_text_start = (long) start_of_text ();
- unexec_data_start = data_start;
-
- /* Machine-dependent fixup for header, or maybe for unexec_text_start */
-#ifdef ADJUST_EXEC_HEADER
- ADJUST_EXEC_HEADER;
-#endif /* ADJUST_EXEC_HEADER */
-
- hdr.a_trsize = 0;
- hdr.a_drsize = 0;
- if (entry_address != 0)
- hdr.a_entry = entry_address;
-
- hdr.a_bss = bss_end - bss_start;
- hdr.a_data = bss_start - data_start;
-#ifdef NO_REMAP
- hdr.a_text = ohdr.a_text;
-#else /* not NO_REMAP */
- hdr.a_text = data_start - unexec_text_start;
-#endif /* not NO_REMAP */
-
-#ifdef A_TEXT_OFFSET
- hdr.a_text += A_TEXT_OFFSET (ohdr);
-#endif
-
- if (write (new, &hdr, sizeof hdr) != sizeof hdr)
- {
- PERROR (new_name);
- }
-
-#ifdef A_TEXT_OFFSET
- hdr.a_text -= A_TEXT_OFFSET (ohdr);
-#endif
-
- return 0;
-
-#endif /* not COFF */
-}
-\f
-/* ****************************************************************
- * copy_text_and_data
- *
- * Copy the text and data segments from memory to the new a.out
- */
-static int
-copy_text_and_data (new)
- int new;
-{
- register char *end;
- register char *ptr;
-
-#ifdef COFF
- lseek (new, (long) text_scnptr, 0);
- ptr = (char *) f_ohdr.text_start;
- end = ptr + f_ohdr.tsize;
- write_segment (new, ptr, end);
-
- lseek (new, (long) data_scnptr, 0);
- ptr = (char *) f_ohdr.data_start;
- end = ptr + f_ohdr.dsize;
- write_segment (new, ptr, end);
-
-#else /* if not COFF */
-
-/* Some machines count the header as part of the text segment.
- That is to say, the header appears in core
- just before the address that start_of_text () returns.
- For them, N_TXTOFF is the place where the header goes.
- We must adjust the seek to the place after the header.
- Note that at this point hdr.a_text does *not* count
- the extra A_TEXT_OFFSET bytes, only the actual bytes of code. */
-
-#ifdef A_TEXT_SEEK
- lseek (new, (long) A_TEXT_SEEK (hdr), 0);
-#else
-#ifdef A_TEXT_OFFSET
- /* Note that on the Sequent machine A_TEXT_OFFSET != sizeof (hdr)
- and sizeof (hdr) is the correct amount to add here. */
- /* In version 19, eliminate this case and use A_TEXT_SEEK whenever
- N_TXTOFF is not right. */
- lseek (new, (long) N_TXTOFF (hdr) + sizeof (hdr), 0);
-#else
- lseek (new, (long) N_TXTOFF (hdr), 0);
-#endif /* no A_TEXT_OFFSET */
-#endif /* no A_TEXT_SEEK */
-
- ptr = (char *) unexec_text_start;
- end = ptr + hdr.a_text;
- write_segment (new, ptr, end);
-
- ptr = (char *) unexec_data_start;
- end = ptr + hdr.a_data;
-/* This lseek is certainly incorrect when A_TEXT_OFFSET
- and I believe it is a no-op otherwise.
- Let's see if its absence ever fails. */
-/* lseek (new, (long) N_TXTOFF (hdr) + hdr.a_text, 0); */
- write_segment (new, ptr, end);
-
-#endif /* not COFF */
-
- return 0;
-}
-
-write_segment (new, ptr, end)
- int new;
- register char *ptr, *end;
-{
- register int i, nwrite, ret;
- char buf[80];
- extern int errno;
- char zeros[128];
-
- bzero (zeros, sizeof zeros);
-
- for (i = 0; ptr < end;)
- {
- /* distance to next multiple of 128. */
- nwrite = (((int) ptr + 128) & -128) - (int) ptr;
- /* But not beyond specified end. */
- if (nwrite > end - ptr) nwrite = end - ptr;
- ret = write (new, ptr, nwrite);
- /* If write gets a page fault, it means we reached
- a gap between the old text segment and the old data segment.
- This gap has probably been remapped into part of the text segment.
- So write zeros for it. */
- if (ret == -1 && errno == EFAULT)
- write (new, zeros, nwrite);
- else if (nwrite != ret)
- {
- sprintf (buf,
- "unexec write failure: addr 0x%x, fileno %d, size 0x%x, wrote 0x%x, errno %d",
- ptr, new, nwrite, ret, errno);
- PERROR (buf);
- }
- i += nwrite;
- ptr += nwrite;
- }
-}
-\f
-/* ****************************************************************
- * copy_sym
- *
- * Copy the relocation information and symbol table from the a.out to the new
- */
-static int
-copy_sym (new, a_out, a_name, new_name)
- int new, a_out;
- char *a_name, *new_name;
-{
- char page[1024];
- int n;
-
- if (a_out < 0)
- return 0;
-
-#ifdef COFF
- if (SYMS_START == 0L)
- return 0;
-#endif /* COFF */
-
-#ifdef COFF
- if (lnnoptr) /* if there is line number info */
- lseek (a_out, lnnoptr, 0); /* start copying from there */
- else
-#endif /* COFF */
- lseek (a_out, SYMS_START, 0); /* Position a.out to symtab. */
-
- while ((n = read (a_out, page, sizeof page)) > 0)
- {
- if (write (new, page, n) != n)
- {
- PERROR (new_name);
- }
- }
- if (n < 0)
- {
- PERROR (a_name);
- }
- return 0;
-}
-\f
-/* ****************************************************************
- * mark_x
- *
- * After succesfully building the new a.out, mark it executable
- */
-static
-mark_x (name)
- char *name;
-{
- struct stat sbuf;
- int um;
- int new = 0; /* for PERROR */
-
- um = umask (777);
- umask (um);
- if (stat (name, &sbuf) == -1)
- {
- PERROR (name);
- }
- sbuf.st_mode |= 0111 & ~um;
- if (chmod (name, sbuf.st_mode) == -1)
- PERROR (name);
-}
-\f
-/*
- * If the COFF file contains a symbol table and a line number section,
- * then any auxiliary entries that have values for x_lnnoptr must
- * be adjusted by the amount that the line number section has moved
- * in the file (bias computed in make_hdr). The #@$%&* designers of
- * the auxiliary entry structures used the absolute file offsets for
- * the line number entry rather than an offset from the start of the
- * line number section!
- *
- * When I figure out how to scan through the symbol table and pick out
- * the auxiliary entries that need adjustment, this routine will
- * be fixed. As it is now, all such entries are wrong and sdb
- * will complain. Fred Fish, UniSoft Systems Inc.
- */
-
-#ifdef COFF
-
-/* This function is probably very slow. Instead of reopening the new
- file for input and output it should copy from the old to the new
- using the two descriptors already open (WRITEDESC and READDESC).
- Instead of reading one small structure at a time it should use
- a reasonable size buffer. But I don't have time to work on such
- things, so I am installing it as submitted to me. -- RMS. */
-
-adjust_lnnoptrs (writedesc, readdesc, new_name)
- int writedesc;
- int readdesc;
- char *new_name;
-{
- register int nsyms;
- register int new;
-#ifdef amdahl_uts
- SYMENT symentry;
- AUXENT auxentry;
-#else
- struct syment symentry;
- struct auxent auxentry;
-#endif
-
- if (!lnnoptr || !f_hdr.f_symptr)
- return 0;
-
- if ((new = open (new_name, 2)) < 0)
- {
- PERROR (new_name);
- return -1;
- }
-
- lseek (new, f_hdr.f_symptr, 0);
- for (nsyms = 0; nsyms < f_hdr.f_nsyms; nsyms++)
- {
- read (new, &symentry, SYMESZ);
- if (symentry.n_numaux)
- {
- read (new, &auxentry, AUXESZ);
- nsyms++;
- if (ISFCN (symentry.n_type)) {
- auxentry.x_sym.x_fcnary.x_fcn.x_lnnoptr += bias;
- lseek (new, -AUXESZ, 1);
- write (new, &auxentry, AUXESZ);
- }
- }
- }
- close (new);
-}
-
-#endif /* COFF */
-
-#endif /* not CANNOT_DUMP */
-\f
-#else /* mips */
-
-/* Unexec for mips machines.
- Note that I regard it as the responsibility of people at Mips
- to tell me about any changes that need to be made in this code.
- I won't take responsibility to think about it even if a change
- I make elsewhere causes it to break. -- RMS. */
-
-#include <sys/types.h>
-#include <sys/file.h>
-#include <sys/stat.h>
-#include <stdio.h>
-#include <varargs.h>
-#include <filehdr.h>
-#include <aouthdr.h>
-#include <scnhdr.h>
-#include <sym.h>
-
-#include "m-mips.h"
-
-#define private static
-\f
-extern int errno;
-extern int sys_nerr;
-extern char *sys_errlist[];
-#define EEOF -1
-
-private void
-fatal(s, va_alist)
- va_dcl
-{
- va_list ap;
- if (errno == EEOF) {
- fputs("unexec: unexpected end of file, ", stderr);
- }
- else if (errno < sys_nerr) {
- fprintf(stderr, "unexec: %s, ", sys_errlist[errno]);
- }
- else {
- fprintf(stderr, "unexec: error code %d, ", errno);
- }
- va_start(ap);
- _doprnt(s, ap, stderr);
- fputs(".\n", stderr);
- exit(1);
-}
-
-#define READ(_fd, _buffer, _size, _error_message, _error_arg) \
- errno = EEOF; \
- if (read(_fd, _buffer, _size) != _size) \
- fatal(_error_message, _error_arg);
-
-#define WRITE(_fd, _buffer, _size, _error_message, _error_arg) \
- if (write(_fd, _buffer, _size) != _size) \
- fatal(_error_message, _error_arg);
-
-#define SEEK(_fd, _position, _error_message, _error_arg) \
- errno = EEOF; \
- if (lseek(_fd, _position, L_SET) != _position) \
- fatal(_error_message, _error_arg);
-\f
-struct headers {
- struct filehdr fhdr;
- struct aouthdr aout;
- struct scnhdr text_section;
- struct scnhdr rdata_section;
- struct scnhdr data_section;
- struct scnhdr sdata_section;
- struct scnhdr sbss_section;
- struct scnhdr bss_section;
-};
-
-unexec (new_name, a_name, data_start, bss_start, entry_address)
- char *new_name, *a_name;
- unsigned data_start, bss_start, entry_address;
-{
- int new, old;
- int pagesize, brk;
- int newsyms, symrel;
- int nread;
- struct headers hdr;
-#define BUFSIZE 8192
- char buffer[BUFSIZE];
-
- old = open (a_name, O_RDONLY, 0);
- if (old < 0) fatal("openning %s", a_name);
-
- new = creat (new_name, 0666);
- if (new < 0) fatal("creating %s", new_name);
-
- hdr = *((struct headers *)TEXT_START);
- if (hdr.fhdr.f_magic != MIPSELMAGIC
- && hdr.fhdr.f_magic != MIPSEBMAGIC) {
- fprintf(stderr, "unexec: input file magic number is %x, not %x or %x.\n",
- hdr.fhdr.f_magic, MIPSELMAGIC, MIPSEBMAGIC);
- exit(1);
- }
- if (hdr.fhdr.f_opthdr != sizeof(hdr.aout)) {
- fprintf(stderr, "unexec: input a.out header is %d bytes, not %d.\n",
- hdr.fhdr.f_opthdr, sizeof(hdr.aout));
- exit(1);
- }
-#if 0
- if (hdr.aout.magic != ZMAGIC
- && hdr.aout.magic != NMAGIC
- && hdr.aout.magic != OMAGIC) {
- fprintf(stderr, "unexec: input file a.out magic number is %o, not %o, %o, or %o.\n",
- hdr.aout.magic, ZMAGIC, NMAGIC, OMAGIC);
- exit(1);
- }
-#else
- if (hdr.aout.magic != ZMAGIC) {
- fprintf(stderr, "unexec: input file a.out magic number is %o, not %o.\n",
- hdr.aout.magic, ZMAGIC);
- exit(1);
- }
-#endif
- if (hdr.fhdr.f_nscns != 6) {
- fprintf(stderr, "unexec: %d sections instead of 6.\n", hdr.fhdr.f_nscns);
- }
-#define CHECK_SCNHDR(field, name, flags) \
- if (strcmp(hdr.field.s_name, name) != 0) { \
- fprintf(stderr, "unexec: %s section where %s expected.\n", \
- hdr.field.s_name, name); \
- exit(1); \
- } \
- else if (hdr.field.s_flags != flags) { \
- fprintf(stderr, "unexec: %x flags where %x expected in %s section.\n", \
- hdr.field.s_flags, flags, name); \
- }
- CHECK_SCNHDR(text_section, _TEXT, STYP_TEXT);
- CHECK_SCNHDR(rdata_section, _RDATA, STYP_RDATA);
- CHECK_SCNHDR(data_section, _DATA, STYP_DATA);
- CHECK_SCNHDR(sdata_section, _SDATA, STYP_SDATA);
- CHECK_SCNHDR(sbss_section, _SBSS, STYP_SBSS);
- CHECK_SCNHDR(bss_section, _BSS, STYP_BSS);
-
- pagesize = getpagesize();
- brk = (sbrk(0) + pagesize - 1) & (-pagesize);
- hdr.aout.dsize = brk - DATA_START;
- hdr.aout.bsize = 0;
- if (entry_address == 0) {
- extern __start();
- hdr.aout.entry = (unsigned)__start;
- }
- else {
- hdr.aout.entry = entry_address;
- }
- hdr.aout.bss_start = hdr.aout.data_start + hdr.aout.dsize;
- hdr.rdata_section.s_size = data_start - DATA_START;
- hdr.data_section.s_vaddr = data_start;
- hdr.data_section.s_paddr = data_start;
- hdr.data_section.s_size = brk - DATA_START;
- hdr.data_section.s_scnptr = hdr.rdata_section.s_scnptr
- + hdr.rdata_section.s_size;
- hdr.sdata_section.s_vaddr = hdr.data_section.s_vaddr
- + hdr.data_section.s_size;
- hdr.sdata_section.s_paddr = hdr.sdata_section.s_paddr;
- hdr.sdata_section.s_size = 0;
- hdr.sdata_section.s_scnptr = hdr.data_section.s_scnptr
- + hdr.data_section.s_size;
- hdr.sbss_section.s_vaddr = hdr.sdata_section.s_vaddr
- + hdr.sdata_section.s_size;
- hdr.sbss_section.s_paddr = hdr.sbss_section.s_vaddr;
- hdr.sbss_section.s_size = 0;
- hdr.sbss_section.s_scnptr = hdr.sdata_section.s_scnptr
- + hdr.sdata_section.s_size;
- hdr.bss_section.s_vaddr = hdr.sbss_section.s_vaddr
- + hdr.sbss_section.s_size;
- hdr.bss_section.s_paddr = hdr.bss_section.s_vaddr;
- hdr.bss_section.s_size = 0;
- hdr.bss_section.s_scnptr = hdr.sbss_section.s_scnptr
- + hdr.sbss_section.s_size;
-
- WRITE(new, TEXT_START, hdr.aout.tsize,
- "writing text section to %s", new_name);
- WRITE(new, DATA_START, hdr.aout.dsize,
- "writing text section to %s", new_name);
-
- SEEK(old, hdr.fhdr.f_symptr, "seeking to start of symbols in %s", a_name);
- errno = EEOF;
- nread = read(old, buffer, BUFSIZE);
- if (nread < sizeof(HDRR)) fatal("reading symbols from %s", a_name);
-#define symhdr ((pHDRR)buffer)
- newsyms = hdr.aout.tsize + hdr.aout.dsize;
- symrel = newsyms - hdr.fhdr.f_symptr;
- hdr.fhdr.f_symptr = newsyms;
- symhdr->cbLineOffset += symrel;
- symhdr->cbDnOffset += symrel;
- symhdr->cbPdOffset += symrel;
- symhdr->cbSymOffset += symrel;
- symhdr->cbOptOffset += symrel;
- symhdr->cbAuxOffset += symrel;
- symhdr->cbSsOffset += symrel;
- symhdr->cbSsExtOffset += symrel;
- symhdr->cbFdOffset += symrel;
- symhdr->cbRfdOffset += symrel;
- symhdr->cbExtOffset += symrel;
-#undef symhdr
- do {
- if (write(new, buffer, nread) != nread)
- fatal("writing symbols to %s", new_name);
- nread = read(old, buffer, BUFSIZE);
- if (nread < 0) fatal("reading symbols from %s", a_name);
-#undef BUFSIZE
- } while (nread != 0);
-
- SEEK(new, 0, "seeking to start of header in %s", new_name);
- WRITE(new, &hdr, sizeof(hdr),
- "writing header of %s", new_name);
-
- close(old);
- close(new);
- mark_x(new_name);
-}
-
-/*
- * mark_x
- *
- * After succesfully building the new a.out, mark it executable
- */
-static
-mark_x (name)
- char *name;
-{
- struct stat sbuf;
- int um = umask (777);
- umask (um);
- if (stat(name, &sbuf) < 0)
- fatal("getting protection on %s", name);
- sbuf.st_mode |= 0111 & ~um;
- if (chmod(name, sbuf.st_mode) < 0)
- fatal("setting protection on %s", name);
-}
-
-#endif /* mips */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/usrdef.h,v 9.36 1987/04/16 02:31:57 jinx Rel $ */
-
-/* Macros and header for usrdef.c and variants. */
-
-#include "config.h"
-#include "object.h"
-#include "errors.h"
-#include "prim.h"
-#include "primitive.h"
-
-extern void
- Microcode_Termination(),
- signal_error_from_primitive();
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Machine Dependent Type Tables
-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $
-
-(declare (usual-integrations))
-
-;;; For quick access to any given table,
-;;; search for the following strings:
-;;;
-;;; [] Fixed
-;;; [] Types
-;;; [] Returns
-;;; [] Primitives
-;;; [] External
-;;; [] Errors
-;;; [] Identification
-\f
-;;; [] Fixed
-
-(vector-set! (get-fixed-objects-vector)
- #x0F ;(fixed-objects-vector-slot 'MICROCODE-FIXED-OBJECTS-SLOTS)
- #(NON-OBJECT ;00
- SYSTEM-INTERRUPT-VECTOR ;01
- SYSTEM-ERROR-VECTOR ;02
- OBARRAY ;03
- MICROCODE-TYPES-VECTOR ;04
- MICROCODE-RETURNS-VECTOR ;05
- MICROCODE-PRIMITIVES-VECTOR ;06
- MICROCODE-ERRORS-VECTOR ;07
- MICROCODE-IDENTIFICATION-VECTOR ;08
- #F ;09
- #F ;0A
- GC-DAEMON ;0B
- TRAP-HANDLER ;0C
- #F ;0D
- STEPPER-STATE ;0E
- MICROCODE-FIXED-OBJECTS-SLOTS ;0F
- MICROCODE-EXTERNAL-PRIMITIVES ;10
- STATE-SPACE-TAG ;11
- STATE-POINT-TAG ;12
- DUMMY-HISTORY ;13
- BIGNUM-ONE ;14
- SCHEDULER ;15
- MICROCODE-TERMINATIONS-VECTOR ;16
- MICROCODE-TERMINATIONS-PROCEDURES ;17
- FIXED-OBJECTS-VECTOR ;18
- THE-WORK-QUEUE ;19
- FUTURE-READS-LOGGER ;1A
- TOUCHED-FUTURES-VECTOR ;1B
- PRECIOUS-OBJECTS ;1C
- ERROR-PROCEDURE ;1D
- UNSNAPPED-LINK ;1E
- MICROCODE-UTILITIES-VECTOR ;1F
- COMPILER-ERROR-PROCEDURE ;20
- LOST-OBJECT-BASE ;21
- STATE-SPACE-ROOT ;22
- MICROCODE-TABLE-IDENTIFICATION ;23
- ))
-\f
-;;; [] Types
-
-(vector-set! (get-fixed-objects-vector)
- 4 ;(fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR)
- #((NULL FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT) ;00
- (PAIR LIST) ;01
- CHARACTER ;02
- QUOTATION ;03
- PRIMITIVE-COMBINATION-2 ;04
- UNINTERNED-SYMBOL ;05
- (FLONUM BIG-FLONUM) ;06
- COMBINATION-1 ;07
- TRUE ;08
- EXTENDED-PROCEDURE ;09
- VECTOR ;0A
- RETURN-ADDRESS ;0B
- COMBINATION-2 ;0C
- COMPILED-PROCEDURE ;0D
- (BIGNUM BIG-FIXNUM) ;0E
- PROCEDURE ;0F
- PRIMITIVE-EXTERNAL ;10
- DELAY ;11
- ENVIRONMENT ;12
- DELAYED ;13
- EXTENDED-LAMBDA ;14
- COMMENT ;15
- NON-MARKED-VECTOR ;16
- LAMBDA ;17
- PRIMITIVE ;18
- SEQUENCE-2 ;19
- (FIXNUM ADDRESS) ;1A
- PRIMITIVE-COMBINATION-1 ;1B
- CONTROL-POINT ;1C
- INTERNED-SYMBOL ;1D
- (STRING CHARACTER-STRING VECTOR-8B) ;1E
- ACCESS ;1F
- #F ;20
- DEFINITION ;21
- BROKEN-HEART ;22
- ASSIGNMENT ;23
- (TRIPLE HUNK3) ;24
- IN-PACKAGE ;25
- COMBINATION ;26
- MANIFEST-NM-VECTOR ;27
- COMPILED-EXPRESSION ;28
- LEXPR ;29
- PRIMITIVE-COMBINATION-3 ;2A
- MANIFEST-SPECIAL-NM-VECTOR ;2B
- VARIABLE ;2C
- THE-ENVIRONMENT ;2D
- FUTURE ;2E
- VECTOR-1B ;2F
- PRIMITIVE-COMBINATION-0 ;30
- VECTOR-16B ;31
- (REFERENCE-TRAP UNASSIGNED) ;32
- SEQUENCE-3 ;33
- CONDITIONAL ;34
- DISJUNCTION ;35
- CELL ;36
- WEAK-CONS ;37
- QUAD ;38
- COMPILER-RETURN-ADDRESS ;39
- COMPILER-LINK ;3A
- STACK-ENVIRONMENT ;3B
- COMPLEX ;3C
- #F ;3D
- #F ;3E
- #F ;3F
- #F ;40
- #F ;41
- #F ;42
- #F ;43
- #F ;44
- #F ;45
- #F ;46
- #F ;47
- #F ;48
- #F ;49
- #F ;4A
- #F ;4B
- #F ;4C
- #F ;4D
- #F ;4E
- #F ;4F
- #F ;50
- #F ;51
- #F ;52
- #F ;53
- #F ;54
- #F ;55
- #F ;56
- #F ;57
- #F ;58
- #F ;59
- #F ;5A
- #F ;5B
- #F ;5C
- #F ;5D
- #F ;5E
- #F ;5F
- #F ;60
- #F ;61
- #F ;62
- #F ;63
- #F ;64
- #F ;65
- #F ;66
- #F ;67
- #F ;68
- #F ;69
- #F ;6A
- #F ;6B
- #F ;6C
- #F ;6D
- #F ;6E
- #F ;6F
- #F ;70
- #F ;71
- #F ;72
- #F ;73
- #F ;74
- #F ;75
- #F ;76
- #F ;77
- #F ;78
- #F ;79
- #F ;7A
- #F ;7B
- #F ;7C
- #F ;7D
- #F ;7E
- #F ;7F
- ))
-\f
-;;; [] Returns
-
-(vector-set! (get-fixed-objects-vector)
- 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)
- #(NON-EXISTENT-CONTINUATION ;00
- JOIN-STACKLETS ;01
- RESTORE-CONTINUATION ;02
- INTERNAL-APPLY ;03
- BAD-INTERRUPT-CONTINUE ;04
- RESTORE-HISTORY ;05
- INVOKE-STACK-THREAD ;06
- RESTART-EXECUTION ;07
- ASSIGNMENT-CONTINUE ;08
- DEFINITION-CONTINUE ;09
- ACCESS-CONTINUE ;0A
- IN-PACKAGE-CONTINUE ;0B
- SEQUENCE-2-SECOND ;0C
- SEQUENCE-3-SECOND ;0D
- SEQUENCE-3-THIRD ;0E
- CONDITIONAL-DECIDE ;0F
- DISJUNCTION-DECIDE ;10
- COMBINATION-1-PROCEDURE ;11
- COMBINATION-APPLY ;12
- COMBINATION-2-FIRST-OPERAND ;13
- COMBINATION-2-PROCEDURE ;14
- COMBINATION-SAVE-VALUE ;15
- PRIMITIVE-COMBINATION-1-APPLY ;16
- PRIMITIVE-COMBINATION-2-FIRST-OPERAND ;17
- PRIMITIVE-COMBINATION-2-APPLY ;18
- PRIMITIVE-COMBINATION-3-SECOND-OPERAND ;19
- PRIMITIVE-COMBINATION-3-FIRST-OPERAND ;1A
- PRIMITIVE-COMBINATION-3-APPLY ;1B
- FORCE-SNAP-THUNK ;1C
- REENTER-COMPILED-CODE ;1D
- #F ;1E
- COMPILER-REFERENCE-RESTART ;1F
- NORMAL-GARBAGE-COLLECT-DONE ;20
- COMPLETE-GARBAGE-COLLECT-DONE ;21
- PURIFY-AFTER-FIRST-GC ;22
- PURIFY-AFTER-SECOND-GC ;23
- AFTER-MEMORY-UPDATE ;24
- RETRY-MICROCODE-TERMINATION-RESTARTABLE ;25
- #F ;26
- #F ;27
- COMPILER-ASSIGNMENT-RESTART ;28
- POP-FROM-COMPILED-CODE ;29
- RETURN-TRAP-POINT ;2A
- RESTORE-STEPPER ;2B
- RESTORE-TO-STATE-POINT ;2C
- MOVE-TO-ADJACENT-POINT ;2D
- RESTORE-VALUE ;2E
- RESTORE-DONT-COPY-HISTORY ;2F
- #F ;30
- #F ;31
- #F ;32
- #F ;33
- #F ;34
- #F ;35
- #F ;36
- #F ;37
- #F ;38
- #F ;39
- #F ;3A
- #F ;3B
- #F ;3C
- #F ;3D
- #F ;3E
- #F ;3F
- POP-RETURN-ERROR ;40
- EVAL-ERROR ;41
- REPEAT-PRIMITIVE ;42
- COMPILER-INTERRUPT-RESTART ;43
- #F ;44
- RESTORE-INTERRUPT-MASK ;45
- HALT ;46
- FINISH-GLOBAL-INTERRUPT ;47
- REPEAT-DISPATCH ;48
- GC-CHECK ;49
- RESTORE-FLUIDS ;4A
- COMPILER-LOOKUP-APPLY-RESTART ;4B
- COMPILER-ACCESS-RESTART ;4C
- COMPILER-UNASSIGNED?-RESTART ;4D
- COMPILER-UNBOUND?-RESTART ;4E
- COMPILER-DEFINITION-RESTART ;4F
- COMPILER-LEXPR-INTERRUPT-RESTART ;50
- ))
-\f
-;;; [] Primitives
-
-(vector-set! (get-fixed-objects-vector)
- 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)
- #(LEXICAL-ASSIGNMENT ;$00
- LOCAL-REFERENCE ;$01
- LOCAL-ASSIGNMENT ;$02
- CALL-WITH-CURRENT-CONTINUATION ;$03
- SCODE-EVAL ;$04
- APPLY ;$05
- SET-INTERRUPT-ENABLES! ;$06
- STRING->SYMBOL ;$07
- GET-WORK ;$08
- NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09
- CURRENT-DYNAMIC-STATE ;$0A
- SET-CURRENT-DYNAMIC-STATE! ;$0B
- (NULL? NOT FALSE?) ;$0C
- EQ? ;$0D
- STRING-EQUAL? ;$0E
- PRIMITIVE-TYPE? ;$0F
- PRIMITIVE-TYPE ;$10
- PRIMITIVE-SET-TYPE ;$11
- LEXICAL-REFERENCE ;$12
- LEXICAL-UNREFERENCEABLE? ;$13
- MAKE-CHAR ;$14
- CHAR-BITS ;$15
- EXIT ;$16
- CHAR-CODE ;$17
- LEXICAL-UNASSIGNED? ;$18
- INSERT-NON-MARKED-VECTOR! ;$19
- HALT ;$1A
- CHAR->INTEGER ;$1B
- MEMQ ;$1C
- INSERT-STRING ;$1D
- ENABLE-INTERRUPTS! ;$1E
- MAKE-EMPTY-STRING ;$1F
- CONS ;$20
- (CAR FIRST) ;$21
- (CDR FIRST-TAIL) ;$22
- (SET-CAR! SET-FIRST!) ;$23
- (SET-CDR! SET-FIRST-TAIL!) ;$24
- #F ;$25
- TTY-GET-CURSOR ;$26
- GENERAL-CAR-CDR ;$27
- HUNK3-CONS ;$28
- HUNK3-CXR ;$29
- HUNK3-SET-CXR! ;$2A
- INSERT-STRING! ;$2B
- VECTOR-CONS ;$2C
- (VECTOR-LENGTH VECTOR-SIZE) ;$2D
- VECTOR-REF ;$2E
- SET-CURRENT-HISTORY! ;$2F
- VECTOR-SET! ;$30
- NON-MARKED-VECTOR-CONS ;$31
- #F ;$32
- LEXICAL-UNBOUND? ;$33
- INTEGER->CHAR ;$34
- CHAR-DOWNCASE ;$35
- CHAR-UPCASE ;$36
- ASCII->CHAR ;$37
- CHAR-ASCII? ;$38
- CHAR->ASCII ;$39
- GARBAGE-COLLECT ;$3A
- PLUS-FIXNUM ;$3B
- MINUS-FIXNUM ;$3C
- MULTIPLY-FIXNUM ;$3D
- DIVIDE-FIXNUM ;$3E
- EQUAL-FIXNUM? ;$3F
- LESS-THAN-FIXNUM? ;$40
- POSITIVE-FIXNUM? ;$41
- ONE-PLUS-FIXNUM ;$42
- MINUS-ONE-PLUS-FIXNUM ;$43
- TRUNCATE-STRING! ;$44
- SUBSTRING ;$45
- ZERO-FIXNUM? ;$46
- MAKE-OBJECT-SAFE ;$47
- MAKE-OBJECT-DANGEROUS ;$48
- OBJECT-DANGEROUS? ;$49
- SUBSTRING->LIST ;$4A
- MAKE-FILLED-STRING ;$4B
- PLUS-BIGNUM ;$4C
- MINUS-BIGNUM ;$4D
- MULTIPLY-BIGNUM ;$4E
- DIVIDE-BIGNUM ;$4F
- LISTIFY-BIGNUM ;$50
- EQUAL-BIGNUM? ;$51
- LESS-THAN-BIGNUM? ;$52
- POSITIVE-BIGNUM? ;$53
- FILE-OPEN-CHANNEL ;$54
- FILE-CLOSE-CHANNEL ;$55
- PRIMITIVE-FASDUMP ;$56
- BINARY-FASLOAD ;$57
- STRING-POSITION ;$58
- STRING-LESS? ;$59
- #F ;$5A
- #F ;$5B
- REHASH ;$5C
- LENGTH ;$5D
- ASSQ ;$5E
- LIST->STRING ;$5F
- EQUAL-STRING-TO-LIST? ;$60
- MAKE-CELL ;$61
- CELL-CONTENTS ;$62
- CELL? ;$63
- CHARACTER-UPCASE ;$64
- CHARACTER-LIST-HASH ;$65
- GCD-FIXNUM ;$66
- COERCE-FIXNUM-TO-BIGNUM ;$67
- COERCE-BIGNUM-TO-FIXNUM ;$68
- PLUS-FLONUM ;$69
- MINUS-FLONUM ;$6A
- MULTIPLY-FLONUM ;$6B
- DIVIDE-FLONUM ;$6C
- EQUAL-FLONUM? ;$6D
- LESS-THAN-FLONUM? ;$6E
- ZERO-BIGNUM? ;$6F
- TRUNCATE-FLONUM ;$70
- ROUND-FLONUM ;$71
- COERCE-INTEGER-TO-FLONUM ;$72
- SINE-FLONUM ;$73
- COSINE-FLONUM ;$74
- ARCTAN-FLONUM ;$75
- EXP-FLONUM ;$76
- LN-FLONUM ;$77
- SQRT-FLONUM ;$78
- PRIMITIVE-FASLOAD ;$79
- GET-FIXED-OBJECTS-VECTOR ;$7A
- SET-FIXED-OBJECTS-VECTOR! ;$7B
- LIST->VECTOR ;$7C
- SUBVECTOR->LIST ;$7D
- PAIR? ;$7E
- NEGATIVE-FIXNUM? ;$7F
- NEGATIVE-BIGNUM? ;$80
- GREATER-THAN-FIXNUM? ;$81
- GREATER-THAN-BIGNUM? ;$82
- STRING-HASH ;$83
- SYSTEM-PAIR-CONS ;$84
- SYSTEM-PAIR? ;$85
- SYSTEM-PAIR-CAR ;$86
- SYSTEM-PAIR-CDR ;$87
- SYSTEM-PAIR-SET-CAR! ;$88
- SYSTEM-PAIR-SET-CDR! ;$89
- #F ;$8A
- #F ;$8B
- SET-CELL-CONTENTS! ;$8C
- &MAKE-OBJECT ;$8D
- SYSTEM-HUNK3-CXR0 ;$8E
- SYSTEM-HUNK3-SET-CXR0! ;$8F
- MAP-MACHINE-ADDRESS-TO-CODE ;$90
- SYSTEM-HUNK3-CXR1 ;$91
- SYSTEM-HUNK3-SET-CXR1! ;$92
- MAP-CODE-TO-MACHINE-ADDRESS ;$93
- SYSTEM-HUNK3-CXR2 ;$94
- SYSTEM-HUNK3-SET-CXR2! ;$95
- PRIMITIVE-PROCEDURE-ARITY ;$96
- SYSTEM-LIST-TO-VECTOR ;$97
- SYSTEM-SUBVECTOR-TO-LIST ;$98
- SYSTEM-VECTOR? ;$99
- SYSTEM-VECTOR-REF ;$9A
- SYSTEM-VECTOR-SET! ;$9B
- WITH-HISTORY-DISABLED ;$9C
- #F ;$9D
- #F ;$9E
- #F ;$9F
- #F ;$A0
- #F ;$A1
- #F ;$A2
- VECTOR-8B-CONS ;$A3
- VECTOR-8B? ;$A4
- VECTOR-8B-REF ;$A5
- VECTOR-8B-SET! ;$A6
- ZERO-FLONUM? ;$A7
- POSITIVE-FLONUM? ;$A8
- NEGATIVE-FLONUM? ;$A9
- GREATER-THAN-FLONUM? ;$AA
- INTERN-CHARACTER-LIST ;$AB
- #F ;$AC
- (STRING-SIZE VECTOR-8B-SIZE) ;$AD
- SYSTEM-VECTOR-SIZE ;$AE
- FORCE ;$AF
- PRIMITIVE-DATUM ;$B0
- MAKE-NON-POINTER-OBJECT ;$B1
- DEBUGGING-PRINTER ;$B2
- STRING-UPCASE ;$B3
- PRIMITIVE-PURIFY ;$B4
- #F ;$B5
- COMPLETE-GARBAGE-COLLECT ;$B6
- DUMP-BAND ;$B7
- SUBSTRING-SEARCH ;$B8
- LOAD-BAND ;$B9
- CONSTANT? ;$BA
- PURE? ;$BB
- PRIMITIVE-GC-TYPE ;$BC
- PRIMITIVE-IMPURIFY ;$BD
- WITH-THREADED-CONTINUATION ;$BE
- WITHIN-CONTROL-POINT ;$BF
- SET-RUN-LIGHT! ;$C0
- FILE-EOF? ;$C1
- FILE-READ-CHAR ;$C2
- FILE-FILL-INPUT-BUFFER ;$C3
- FILE-LENGTH ;$C4
- FILE-WRITE-CHAR ;$C5
- FILE-WRITE-STRING ;$C6
- CLOSE-LOST-OPEN-FILES ;$C7
- #F ;$C8
- WITH-INTERRUPTS-REDUCED ;$C9
- PRIMITIVE-EVAL-STEP ;$CA
- PRIMITIVE-APPLY-STEP ;$CB
- PRIMITIVE-RETURN-STEP ;$CC
- TTY-READ-CHAR-READY? ;$CD
- TTY-READ-CHAR ;$CE
- TTY-READ-CHAR-IMMEDIATE ;$CF
- TTY-READ-FINISH ;$D0
- BIT-STRING-ALLOCATE ;$D1
- MAKE-BIT-STRING ;$D2
- BIT-STRING? ;$D3
- BIT-STRING-LENGTH ;$D4
- BIT-STRING-REF ;$D5
- BIT-SUBSTRING-MOVE-RIGHT! ;$D6
- BIT-STRING-SET! ;$D7
- BIT-STRING-CLEAR! ;$D8
- BIT-STRING-ZERO? ;$D9
- #F ;$DA
- #F ;$DB
- UNSIGNED-INTEGER->BIT-STRING ;$DC
- BIT-STRING->UNSIGNED-INTEGER ;$DD
- #F ;$DE
- READ-BITS! ;$DF
- WRITE-BITS! ;$E0
- MAKE-STATE-SPACE ;$E1
- EXECUTE-AT-NEW-STATE-POINT ;$E2
- TRANSLATE-TO-STATE-POINT ;$E3
- GET-NEXT-CONSTANT ;$E4
- MICROCODE-IDENTIFY ;$E5
- ZERO? ;$E6
- POSITIVE? ;$E7
- NEGATIVE? ;$E8
- &= ;$E9
- &< ;$EA
- &> ;$EB
- &+ ;$EC
- &- ;$ED
- &* ;$EE
- &/ ;$EF
- INTEGER-DIVIDE ;$F0
- 1+ ;$F1
- -1+ ;$F2
- TRUNCATE ;$F3
- ROUND ;$F4
- FLOOR ;$F5
- CEILING ;$F6
- SQRT ;$F7
- EXP ;$F8
- LOG ;$F9
- SIN ;$FA
- COS ;$FB
- &ATAN ;$FC
- TTY-WRITE-CHAR ;$FD
- TTY-WRITE-STRING ;$FE
- TTY-BEEP ;$FF
- TTY-CLEAR ;$100
- GET-EXTERNAL-COUNTS ;$101
- GET-EXTERNAL-NAME ;$102
- GET-EXTERNAL-NUMBER ;$103
- #F ;$104
- #F ;$105
- GET-NEXT-INTERRUPT-CHARACTER ;$106
- CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
- #F ;$108
- SYSTEM-CLOCK ;$109
- FILE-EXISTS? ;$10A
- #F ;$10B
- TTY-MOVE-CURSOR ;$10C
- #F ;$10D
- CURRENT-DATE ;$10E
- CURRENT-TIME ;$10F
- TRANSLATE-FILE ;$110
- COPY-FILE ;$111
- RENAME-FILE ;$112
- REMOVE-FILE ;$113
- LINK-FILE ;$114
- MAKE-DIRECTORY ;$115
- VOLUME-NAME ;$116
- SET-WORKING-DIRECTORY-PATHNAME! ;$117
- OPEN-CATALOG ;$118
- CLOSE-CATALOG ;$119
- NEXT-FILE ;$11A
- CAT-NAME ;$11B
- CAT-KIND ;$11C
- CAT-PSIZE ;$11D
- CAT-LSIZE ;$11E
- CAT-INFO ;$11F
- CAT-BLOCK ;$120
- CAT-CREATE-DATE ;$121
- CAT-CREATE-TIME ;$122
- CAT-LAST-DATE ;$123
- CAT-LAST-TIME ;$124
- ERROR-MESSAGE ;$125
- CURRENT-YEAR ;$126
- CURRENT-MONTH ;$127
- CURRENT-DAY ;$128
- CURRENT-HOUR ;$129
- CURRENT-MINUTE ;$12A
- CURRENT-SECOND ;$12B
- INIT-FLOPPY ;$12C
- ZERO-FLOPPY ;$12D
- PACK-VOLUME ;$12E
- LOAD-PICTURE ;$12F
- STORE-PICTURE ;$130
- LOOKUP-SYSTEM-SYMBOL ;$131
- #F ;$132
- #F ;$133
- CLEAR-TO-END-OF-LINE ;$134
- #F ;$135
- #F ;$136
- WITH-INTERRUPT-MASK ;$137
- STRING? ;$138
- STRING-LENGTH ;$139
- STRING-REF ;$13A
- STRING-SET! ;$13B
- SUBSTRING-MOVE-RIGHT! ;$13C
- SUBSTRING-MOVE-LEFT! ;$13D
- STRING-ALLOCATE ;$13E
- STRING-MAXIMUM-LENGTH ;$13F
- SET-STRING-LENGTH! ;$140
- VECTOR-8B-FILL! ;$141
- VECTOR-8B-FIND-NEXT-CHAR ;$142
- VECTOR-8B-FIND-PREVIOUS-CHAR ;$143
- VECTOR-8B-FIND-NEXT-CHAR-CI ;$144
- VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145
- SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146
- SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147
- SUBSTRING=? ;$148
- SUBSTRING-CI=? ;$149
- SUBSTRING<? ;$14A
- SUBSTRING-UPCASE! ;$14B
- SUBSTRING-DOWNCASE! ;$14C
- SUBSTRING-MATCH-FORWARD ;$14D
- SUBSTRING-MATCH-BACKWARD ;$14E
- SUBSTRING-MATCH-FORWARD-CI ;$14F
- SUBSTRING-MATCH-BACKWARD-CI ;$150
- PHOTO-OPEN ;$151
- PHOTO-CLOSE ;$152
- SETUP-TIMER-INTERRUPT ;$153
- #F ;$154
- #F ;$155
- #F ;$156
- #F ;$157
- #F ;$158
- #F ;$159
- #F ;$15A
- #F ;$15B
- #F ;$15C
- #F ;$15D
- #F ;$15E
- #F ;$15F
- #F ;$160
- EXTRACT-NON-MARKED-VECTOR ;$161
- UNSNAP-LINKS! ;$162
- SAFE-PRIMITIVE? ;$163
- SUBSTRING-READ ;$164
- SUBSTRING-WRITE ;$165
- SCREEN-X-SIZE ;$166
- SCREEN-Y-SIZE ;$167
- SCREEN-WRITE-CURSOR ;$168
- SCREEN-WRITE-CHARACTER ;$169
- SCREEN-WRITE-SUBSTRING ;$16A
- NEXT-FILE-MATCHING ;$16B
- #F ;$16C
- TTY-WRITE-BYTE ;$16D
- FILE-READ-BYTE ;$16E
- FILE-WRITE-BYTE ;$16F
- #F #| SAVE-SCREEN |# ;$170
- #F #| RESTORE-SCREEN! |# ;$171
- #F #| SUBSCREEN-CLEAR! |# ;$172
- #F #| &GCD |# ;$173
- #F #| TTY-REDRAW-SCREEN |# ;$174
- #F #| SCREEN-INVERSE-VIDEO! |# ;$175
- STRING->SYNTAX-ENTRY ;$176
- SCAN-WORD-FORWARD ;$177
- SCAN-WORD-BACKWARD ;$178
- SCAN-LIST-FORWARD ;$179
- SCAN-LIST-BACKWARD ;$17A
- SCAN-SEXPS-FORWARD ;$17B
- SCAN-FORWARD-TO-WORD ;$17C
- SCAN-BACKWARD-PREFIX-CHARS ;$17D
- CHAR->SYNTAX-CODE ;$17E
- QUOTED-CHAR? ;$17F
- MICROCODE-TABLES-FILENAME ;$180
- #F ;$181
- #F #| FIND-PASCAL-PROGRAM |# ;$182
- #F #| EXECUTE-PASCAL-PROGRAM |# ;$183
- #F #| GRAPHICS-MOVE |# ;$184
- #F #| GRAPHICS-LINE |# ;$185
- #F #| GRAPHICS-PIXEL |# ;$186
- #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187
- #F #| ALPHA-RASTER? |# ;$188
- #F #| TOGGLE-ALPHA-RASTER |# ;$189
- #F #| GRAPHICS-RASTER? |# ;$18A
- #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B
- #F #| GRAPHICS-CLEAR |# ;$18C
- #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D
- ERROR-PROCEDURE ;$18E
- VOLUME-EXISTS? ;$18F
- RE-CHAR-SET-ADJOIN! ;$190
- RE-COMPILE-FASTMAP ;$191
- RE-MATCH ;$192
- RE-SEARCH-FORWARD ;$193
- RE-SEARCH-BACKWARD ;$194
- (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
- (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
- BIT-STRING-FILL! ;$197
- BIT-STRING-MOVE! ;$198
- BIT-STRING-MOVEC! ;$199
- BIT-STRING-OR! ;$19A
- BIT-STRING-AND! ;$19B
- BIT-STRING-ANDC! ;$19C
- BIT-STRING=? ;$19D
- WORKING-DIRECTORY-PATHNAME ;$19E
- OPEN-DIRECTORY ;$19F
- DIRECTORY-READ ;$1A0
- UNDER-EMACS? ;$1A1
- TTY-FLUSH-OUTPUT ;$1A2
- RELOAD-BAND-NAME ;$1A3
- ))
-\f
-;;; [] External
-
-(vector-set! (get-fixed-objects-vector)
- 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES)
- #())
-\f
-;;; [] Errors
-
-(vector-set! (get-fixed-objects-vector)
- 7 ;(fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)
- #(BAD-ERROR-CODE ;00
- UNBOUND-VARIABLE ;01
- UNASSIGNED-VARIABLE ;02
- UNDEFINED-PROCEDURE ;03
- #F ;04
- #F ;05
- BAD-FRAME ;06
- BROKEN-CVARIABLE ;07
- UNDEFINED-USER-TYPE ;08
- UNDEFINED-PRIMITIVE-OPERATION ;09
- EXTERNAL-RETURN ;0A
- EXECUTE-MANIFEST-VECTOR ;0B
- WRONG-NUMBER-OF-ARGUMENTS ;0C
- WRONG-TYPE-ARGUMENT-0 ;0D
- WRONG-TYPE-ARGUMENT-1 ;0E
- WRONG-TYPE-ARGUMENT-2 ;0F
- BAD-RANGE-ARGUMENT-0 ;10
- BAD-RANGE-ARGUMENT-1 ;11
- BAD-RANGE-ARGUMENT-2 ;12
- #F ;13
- #F ;14
- BAD-INTERRUPT-CODE ;15
- #F ;16
- FASL-FILE-TOO-BIG ;17
- FASL-FILE-BAD-DATA ;18
- IMPURIFY-OBJECT-TOO-LARGE ;19
- WRITE-INTO-PURE-SPACE ;1A
- #F ;1B
- #F ;1C
- #F ;1D
- FAILED-ARG-1-COERCION ;1E
- FAILED-ARG-2-COERCION ;1F
- OUT-OF-FILE-HANDLES ;20
- #F ;21
- BAD-RANGE-ARGUMENT-3 ;22
- BAD-RANGE-ARGUMENT-4 ;23
- BAD-RANGE-ARGUMENT-5 ;24
- BAD-RANGE-ARGUMENT-6 ;25
- BAD-RANGE-ARGUMENT-7 ;26
- BAD-RANGE-ARGUMENT-8 ;27
- BAD-RANGE-ARGUMENT-9 ;28
- WRONG-TYPE-ARGUMENT-3 ;29
- WRONG-TYPE-ARGUMENT-4 ;2A
- WRONG-TYPE-ARGUMENT-5 ;2B
- WRONG-TYPE-ARGUMENT-6 ;2C
- WRONG-TYPE-ARGUMENT-7 ;2D
- WRONG-TYPE-ARGUMENT-8 ;2E
- WRONG-TYPE-ARGUMENT-9 ;2F
- INAPPLICABLE-CONTINUATION ;30
- COMPILED-CODE-ERROR ;31
- FLOATING-OVERFLOW ;32
- UNIMPLEMENTED-PRIMITIVE ;33
- ))
-\f
-;;; [] Terminations
-
-(vector-set! (get-fixed-objects-vector)
- 22 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR)
- #(HALT ;00
- DISK-RESTORE ;01
- BROKEN-HEART ;02
- NON-POINTER-RELOCATION ;03
- BAD-ROOT ;04
- NON-EXISTENT-CONTINUATION ;05
- BAD-STACK ;06
- STACK-OVERFLOW ;07
- STACK-ALLOCATION-FAILED ;08
- NO-ERROR-HANDLER ;09
- NO-INTERRUPT-HANDLER ;0A
- UNIMPLEMENTED-CONTINUATION ;0B
- EXIT ;0C
- BAD-PRIMITIVE-DURING-ERROR ;0D
- EOF ;0E
- BAD-PRIMITIVE ;0F
- TERMINATION-HANDLER ;10
- END-OF-CONTINUATION ;11
- INVALID-TYPE-CODE ;12
- COMPILER-DEATH ;13
- GC-OUT-OF-SPACE ;14
- ))
-
-(vector-set! (get-fixed-objects-vector)
- 23 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATION-PROCEDURES)
- #())
-\f
-;;; [] Identification
-
-(vector-set! (get-fixed-objects-vector)
- 8 ;(fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR)
- #(SYSTEM-RELEASE-STRING ;00
- MICROCODE-VERSION ;01
- MICROCODE-MODIFICATION ;02
- CONSOLE-WIDTH ;03
- CONSOLE-HEIGHT ;04
- NEWLINE-CHAR ;05
- FLONUM-MANTISSA-LENGTH ;06
- FLONUM-EXPONENT-LENGTH ;07
- OS-NAME-STRING ;08
- OS-VARIANT-STRING ;09
- ))
-
-;;; This identification string is saved by the system.
-
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $"
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.23 1987/04/16 02:32:25 jinx Exp $ */
-
-/* This file contains utilities for interrupts, errors, etc. */
-
-#include "scheme.h"
-#include "primitive.h"
-#include "flonum.h"
-#include "winder.h"
-\f
-/* Set_Up_Interrupt is called from the Interrupt
- * macro to do all of the setup for calling the user's
- * interrupt routines.
- */
-
-void
-Setup_Interrupt (Masked_Interrupts)
- long Masked_Interrupts;
-{
- Pointer Int_Vector, Handler;
- long i, Int_Number, The_Int_Code = IntCode, New_Int_Enb;
- long Save_Space;
-
- Int_Vector = Get_Fixed_Obj_Slot(System_Interrupt_Vector);
-
- for (Int_Number=0, i=1;
- Int_Number < MAX_INTERRUPT_NUMBER;
- i = i<<1, Int_Number++)
- if ((Masked_Interrupts & i) != 0)
- goto OK;
-
- fprintf(stderr, "\nInterrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
- IntCode, IntEnb, Masked_Interrupts);
- fprintf(stderr, "Int_Vector %x\n", Int_Vector);
- Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
-
-OK:
- New_Int_Enb = (1<<Int_Number) - 1;
- Global_Interrupt_Hook();
- if (Int_Number > Vector_Length(Int_Vector))
- { fprintf(stderr,
- "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n",
- Int_Number, Vector_Length(Int_Vector));
- fprintf(stderr,
- "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
- IntCode, IntEnb, Masked_Interrupts);
- Microcode_Termination(TERM_NO_INTERRUPT_HANDLER);
- }
- else Handler = User_Vector_Ref(Int_Vector, Int_Number);
-
-/* Setup_Interrupt continues on the next page */
-\f
-/* Setup_Interrupt, continued */
-
-Passed_Checks: /* This label may be used in Global_Interrupt_Hook */
- Stop_History();
- Save_Space = CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3;
- if (New_Int_Enb+1 == INT_GC) Save_Space += CONTINUATION_SIZE;
- Will_Push(Save_Space);
- /* Return from interrupt handler will re-enable interrupts */
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- Save_Cont();
- if (New_Int_Enb+1 == INT_GC)
- { Store_Return(RC_GC_CHECK);
- Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed));
- Save_Cont();
- }
-
-/* Now make an environment frame for use in calling the
- * user supplied interrupt routine. It will be given
- * two arguments: the UNmasked interrupt requests, and
- * the currently enabled interrupts.
- */
-
- Push(Make_Unsigned_Fixnum(IntEnb));
- Push(Make_Unsigned_Fixnum(The_Int_Code));
- Push(Handler);
- Push(STACK_FRAME_HEADER+2);
- Pushed();
- IntEnb = New_Int_Enb; /* Turn off interrupts */
- New_Compiler_MemTop();
-}
-\f
- /******************/
- /* ERROR HANDLING */
- /******************/
-
-/* It is assumed that any caller of the error code has already
- * restored its state to a situation which will make it
- * restartable if the error handler returns normally. As a
- * result, the only work to be done on an error is to verify
- * that there is an error handler, save the current continuation and
- * create a new one if entered from Pop_Return rather than Eval,
- * turn off interrupts, and call it with two arguments: Error-Code
- * and Interrupt-Enables.
- */
-
-void
-Err_Print (Micro_Error)
- long Micro_Error;
-{ switch (Micro_Error)
- {
-/* case ERR_BAD_ERROR_CODE:
- printf("unknown error code.\n"); break;
-*/
- case ERR_UNBOUND_VARIABLE:
- printf("unbound variable.\n"); break;
- case ERR_UNASSIGNED_VARIABLE:
- printf("unassigned variable.\n"); break;
- case ERR_INAPPLICABLE_OBJECT:
- printf("Inapplicable operator.\n"); break;
- case ERR_BAD_FRAME:
- printf("bad environment frame.\n"); break;
- case ERR_BROKEN_COMPILED_VARIABLE:
- printf("compiled variable invalid.\n"); break;
- case ERR_UNDEFINED_USER_TYPE:
- printf("undefined type code.\n"); break;
- case ERR_UNDEFINED_PRIMITIVE:
- printf("undefined primitive.\n"); break;
- case ERR_EXTERNAL_RETURN:
- printf("error during 'external' primitive.\n"); break;
- case ERR_EXECUTE_MANIFEST_VECTOR:
- printf("attempt to EVAL a vector.\n"); break;
- case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- printf("wrong number of arguments.\n"); break;
- case ERR_ARG_1_WRONG_TYPE:
- printf("type error argument 1.\n"); break;
- case ERR_ARG_2_WRONG_TYPE:
- printf("type error argument 2.\n"); break;
-
-/* Err_Print continues on the next page */
-\f
-/* Err_Print, continued */
-
- case ERR_ARG_3_WRONG_TYPE:
- printf("type error argument 3.\n"); break;
- case ERR_ARG_1_BAD_RANGE:
- printf("range error argument 1.\n"); break;
- case ERR_ARG_2_BAD_RANGE:
- printf("range error, argument 2.\n"); break;
- case ERR_ARG_3_BAD_RANGE:
- printf("range error, argument 3.\n"); break;
- case ERR_FASL_FILE_TOO_BIG:
- printf("FASL file too large to load.\n"); break;
- case ERR_FASL_FILE_BAD_DATA:
- printf("No such file or not FASL format.\n"); break;
- case ERR_IMPURIFY_OUT_OF_SPACE:
- printf("Not enough room to impurify object.\n"); break;
- case ERR_WRITE_INTO_PURE_SPACE:
- printf("Write into pure area\n"); break;
- case ERR_BAD_SET:
- printf("Attempt to perform side-effect on 'self'.\n"); break;
- case ERR_ARG_1_FAILED_COERCION:
- printf("First argument couldn't be coerced.\n"); break;
- case ERR_ARG_2_FAILED_COERCION:
- printf("Second argument couldn't be coerced.\n"); break;
- case ERR_OUT_OF_FILE_HANDLES:
- printf("Too many open files.\n"); break;
- default:
- printf("Unknown error 0x%x occurred\n.", Micro_Error);
- break;
- }
- return;
-}
-
-void
-Stack_Death ()
-{ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
- Microcode_Termination(TERM_BAD_STACK);
-}
-\f
-/* Back_Out_Of_Primitive sets the registers up so that the backout
- * mechanism in interpret.c will push the primitive number and
- * an appropriate return code so that the primitive can be
- * restarted.
- */
-
-#if (TC_PRIMITIVE == 0) || (TC_PRIMITIVE_EXTERNAL == 0)
-#include "Error: Some primitive type is 0"
-#endif
-
-void
-Back_Out_Of_Primitive ()
-{
- long nargs;
- Pointer expression = Fetch_Expression();
-
- /* When primitives are called from compiled code, the type code may
- * not be in the expression register.
- */
-
- if (Safe_Type_Code(expression) == 0)
- {
- expression = Make_Non_Pointer(TC_PRIMITIVE, expression);
- Store_Expression(expression);
- }
-
- /* Setup a continuation to return to compiled code if the primitive is
- * restarted and completes successfully.
- */
-
- nargs = N_Args_Primitive(Get_Integer(expression));
- if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
- {
- /* This clobbers the expression register. */
- compiler_apply_procedure(nargs);
- Store_Expression(expression);
- }
-
- /* When you come back to the primitive, the environment is
- * irrelevant .... primitives run with no real environment.
- * Similarly, the value register is meaningless.
- */
- Store_Return(RC_REPEAT_PRIMITIVE);
- Store_Env(Make_Non_Pointer(GLOBAL_ENV, END_OF_CHAIN));
- Val = NIL;
-}
-\f
-/* Useful error procedures */
-
-extern void
- signal_error_from_primitive(),
- signal_interrupt_from_primitive(),
- error_wrong_type_arg_1(),
- error_wrong_type_arg_2(),
- error_wrong_type_arg_3(),
- error_wrong_type_arg_4(),
- error_wrong_type_arg_5(),
- error_wrong_type_arg_6(),
- error_wrong_type_arg_7(),
- error_wrong_type_arg_8(),
- error_wrong_type_arg_9(),
- error_wrong_type_arg_10(),
- error_bad_range_arg_1(),
- error_bad_range_arg_2(),
- error_bad_range_arg_3(),
- error_bad_range_arg_4(),
- error_bad_range_arg_5(),
- error_bad_range_arg_6(),
- error_bad_range_arg_7(),
- error_bad_range_arg_8(),
- error_bad_range_arg_9(),
- error_bad_range_arg_10(),
- error_external_return();
-
-void
-signal_error_from_primitive (error_code)
- long error_code;
-{
- Back_Out_Of_Primitive ();
- longjmp (*Back_To_Eval, error_code);
- /*NOTREACHED*/
-}
-
-void
-signal_interrupt_from_primitive ()
-{
- Back_Out_Of_Primitive ();
- longjmp (*Back_To_Eval, PRIM_INTERRUPT);
- /*NOTREACHED*/
-}
-
-void
-special_interrupt_from_primitive(local_mask)
- int local_mask;
-{
- Back_Out_Of_Primitive();
- Save_Cont();
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- IntEnb = (local_mask);
- longjmp(*Back_To_Eval, PRIM_INTERRUPT);
- /*NOTREACHED*/
-}
-
-void
-error_wrong_type_arg_1 ()
-{
- signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_2 ()
-{
- signal_error_from_primitive (ERR_ARG_2_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_3 ()
-{
- signal_error_from_primitive (ERR_ARG_3_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_4 ()
-{
- signal_error_from_primitive (ERR_ARG_4_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_5 ()
-{
- signal_error_from_primitive (ERR_ARG_5_WRONG_TYPE);
-}
-\f
-void
-error_wrong_type_arg_6 ()
-{
- signal_error_from_primitive (ERR_ARG_6_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_7 ()
-{
- signal_error_from_primitive (ERR_ARG_7_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_8 ()
-{
- signal_error_from_primitive (ERR_ARG_8_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_9 ()
-{
- signal_error_from_primitive (ERR_ARG_9_WRONG_TYPE);
-}
-
-void
-error_wrong_type_arg_10 ()
-{
- signal_error_from_primitive (ERR_ARG_10_WRONG_TYPE);
-}
-
-void
-error_bad_range_arg_1 ()
-{
- signal_error_from_primitive (ERR_ARG_1_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_2 ()
-{
- signal_error_from_primitive (ERR_ARG_2_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_3 ()
-{
- signal_error_from_primitive (ERR_ARG_3_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_4 ()
-{
- signal_error_from_primitive (ERR_ARG_4_BAD_RANGE);
-}
-\f
-void
-error_bad_range_arg_5 ()
-{
- signal_error_from_primitive (ERR_ARG_5_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_6 ()
-{
- signal_error_from_primitive (ERR_ARG_6_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_7 ()
-{
- signal_error_from_primitive (ERR_ARG_7_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_8 ()
-{
- signal_error_from_primitive (ERR_ARG_8_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_9 ()
-{
- signal_error_from_primitive (ERR_ARG_9_BAD_RANGE);
-}
-
-void
-error_bad_range_arg_10 ()
-{
- signal_error_from_primitive (ERR_ARG_10_BAD_RANGE);
-}
-
-void
-error_external_return ()
-{
- signal_error_from_primitive (ERR_EXTERNAL_RETURN);
-}
-\f
-#define define_integer_guarantee(procedure_name, wta, bra) \
-long \
-procedure_name (argument) \
- Pointer argument; \
-{ \
- if (! (fixnum_p (argument))) \
- wta (); \
- if (fixnum_negative_p (argument)) \
- bra (); \
- return (pointer_datum (argument)); \
-}
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_1,
- error_wrong_type_arg_1,
- error_bad_range_arg_1)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_2,
- error_wrong_type_arg_2,
- error_bad_range_arg_2)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_3,
- error_wrong_type_arg_3,
- error_bad_range_arg_3)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_4,
- error_wrong_type_arg_4,
- error_bad_range_arg_4)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_5,
- error_wrong_type_arg_5,
- error_bad_range_arg_5)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_6,
- error_wrong_type_arg_6,
- error_bad_range_arg_6)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_7,
- error_wrong_type_arg_7,
- error_bad_range_arg_7)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_8,
- error_wrong_type_arg_8,
- error_bad_range_arg_8)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_9,
- error_wrong_type_arg_9,
- error_bad_range_arg_9)
-
-define_integer_guarantee (guarantee_nonnegative_int_arg_10,
- error_wrong_type_arg_10,
- error_bad_range_arg_10)
-\f
-#define define_index_guarantee(procedure_name, wta, bra) \
-long \
-procedure_name (argument, upper_limit) \
- Pointer argument, upper_limit; \
-{ \
- fast long index; \
- \
- if (! (fixnum_p (argument))) \
- wta (); \
- if (fixnum_negative_p (argument)) \
- bra (); \
- index = (pointer_datum (argument)); \
- if (index >= upper_limit) \
- bra (); \
- return (index); \
-}
-
-define_index_guarantee (guarantee_index_arg_1,
- error_wrong_type_arg_1,
- error_bad_range_arg_1)
-
-define_index_guarantee (guarantee_index_arg_2,
- error_wrong_type_arg_2,
- error_bad_range_arg_2)
-
-define_index_guarantee (guarantee_index_arg_3,
- error_wrong_type_arg_3,
- error_bad_range_arg_3)
-
-define_index_guarantee (guarantee_index_arg_4,
- error_wrong_type_arg_4,
- error_bad_range_arg_4)
-
-define_index_guarantee (guarantee_index_arg_5,
- error_wrong_type_arg_5,
- error_bad_range_arg_5)
-
-define_index_guarantee (guarantee_index_arg_6,
- error_wrong_type_arg_6,
- error_bad_range_arg_6)
-
-define_index_guarantee (guarantee_index_arg_7,
- error_wrong_type_arg_7,
- error_bad_range_arg_7)
-
-define_index_guarantee (guarantee_index_arg_8,
- error_wrong_type_arg_8,
- error_bad_range_arg_8)
-
-define_index_guarantee (guarantee_index_arg_9,
- error_wrong_type_arg_9,
- error_bad_range_arg_9)
-
-define_index_guarantee (guarantee_index_arg_10,
- error_wrong_type_arg_10,
- error_bad_range_arg_10)
-\f
-void
-Do_Micro_Error (Err, From_Pop_Return)
- long Err;
- Boolean From_Pop_Return;
-{
- Pointer Error_Vector, Handler;
-
- if (Consistency_Check)
- { Err_Print(Err);
- Print_Expression(Fetch_Expression(), "Expression was");
- printf("\nEnvironment 0x%x (#%o).\n", Fetch_Env(), Fetch_Env());
- Print_Return("Return code");
- printf( "\n");
- }
-
- Error_Exit_Hook();
-
- if (Trace_On_Error)
- {
- printf( "\n**** Stack Trace ****\n\n");
- Back_Trace();
- }
-
-#ifdef ENABLE_DEBUGGING_TOOLS
- {
- int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
-
- for (i=0; i < local_nslots; i++) *To++ = *From++;
- debug_nslots = local_nslots;
- debug_slotno = local_slotno;
- }
-#endif
-
-/* Do_Micro_Error continues on the next page. */
-\f
-/* Do_Micro_Error, continued */
-
- if ((!Valid_Fixed_Obj_Vector()) ||
- (Type_Code((Error_Vector =
- Get_Fixed_Obj_Slot(System_Error_Vector))) !=
- TC_VECTOR))
- {
- fprintf(stderr,
- "\nMicrocode Error: code = 0x%x; Bad error handlers vector.\n",
- Err);
- printf("\n**** Stack Trace ****\n\n");
- Back_Trace();
- Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
- }
-
- if (Err >= Vector_Length(Error_Vector))
- {
- if (Vector_Length(Error_Vector) == 0)
- {
- fprintf(stderr,
- "\nMicrocode Error: code = 0x%x; Empty error handlers vector.\n",
- Err);
- printf("\n**** Stack Trace ****\n\n");
- Back_Trace();
- Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
- }
- Handler = User_Vector_Ref(Error_Vector, ERR_BAD_ERROR_CODE);
- }
- else
- Handler = User_Vector_Ref(Error_Vector, Err);
-\f
- /* This can NOT be folded into the Will_Push below since we cannot
- afford to have the Will_Push put down its own continuation.
- There is guaranteed to be enough space for this one
- continuation; in fact, the Will_Push here is really unneeded!
- */
-
- if (From_Pop_Return)
- {
- Will_Push(CONTINUATION_SIZE);
- Save_Cont();
- Pushed();
- }
- Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_SIZE+
- (From_Pop_Return ? 0 : 1));
-
- if (From_Pop_Return)
- Store_Expression(Val);
- else
- Push(Fetch_Env());
-
- Store_Return((From_Pop_Return) ?
- RC_POP_RETURN_ERROR :
- RC_EVAL_ERROR);
- Save_Cont();
-
- /* Return from error handler will re-enable interrupts & restore history */
-
- Stop_History();
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */
- Push(Make_Unsigned_Fixnum(Err)); /* Arg 1: Err. No */
- Push(Handler); /* Procedure: Handler */
- Push(STACK_FRAME_HEADER+2);
- Pushed();
-
- IntEnb = 0; /* Turn off interrupts */
- New_Compiler_MemTop();
-}
-\f
-/* Make a Scheme string with the characters in C_String. */
-
-Pointer
-C_String_To_Scheme_String (C_String)
- fast char *C_String;
-{
- fast char *Next;
- fast long Length, Max_Length;
- Pointer Result;
-
- Result = Make_Pointer( TC_CHARACTER_STRING, Free);
- Next = (char *) Nth_Vector_Loc( Result, STRING_CHARS);
- Max_Length = ((Space_Before_GC() - STRING_CHARS) *
- sizeof( Pointer));
- if (C_String == NULL)
- Length = 0;
- else
- for (Length = 0;
- (*C_String != '\0') && (Length < Max_Length);
- Length += 1)
- *Next++ = *C_String++;
- if (Length >= Max_Length)
- Primitive_GC( MemTop - Free);
- *Next = '\0';
- Free += (2 + ((Length + sizeof( Pointer)) / sizeof( Pointer)));
- Vector_Set(Result, STRING_LENGTH, Length);
- Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer( TC_MANIFEST_NM_VECTOR,
- ((Free - Get_Pointer( Result)) - 1)));
- return Result;
-}
-\f
-Boolean
-Open_File (Name, Mode_String, Handle)
- Pointer Name;
- char *Mode_String;
- FILE **Handle;
-{
- *Handle =
- ((FILE *)
- OS_file_open( Scheme_String_To_C_String( Name), (*Mode_String == 'w')));
- return ((Boolean) (*Handle != NULL));
-}
-
-void
-Close_File (stream)
- FILE *stream;
-{
- extern Boolean OS_file_close();
-
- if (!OS_file_close( stream))
- Primitive_Error( ERR_EXTERNAL_RETURN);
- return;
-}
-
-Pointer *
-Make_Dummy_History ()
-{
- Pointer *History_Rib = Free;
- Pointer *Result;
-
- Free[RIB_EXP] = NIL;
- Free[RIB_ENV] = NIL;
- Free[RIB_NEXT_REDUCTION] =
- Make_Pointer(TC_HUNK3, History_Rib);
- Free += 3;
- Result = Free;
- Free[HIST_RIB] = Make_Pointer(TC_HUNK3, History_Rib);
- Free[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(TC_HUNK3, Result);
- Free[HIST_PREV_SUBPROBLEM] =
- Make_Pointer(TC_HUNK3, Result);
- Free += 3;
- return Result;
-}
-\f
-/* The entire trick to history is right here: it is either copied or
- reused when restored. Initially, Stop_History marks the stack so
- that the history will merely be popped and reused. On a catch,
- however, the return code is changed to force the history to be
- copied instead. Thus, histories saved as part of a control point
- are not side-effected in the history collection process.
-*/
-
-void
-Stop_History ()
-{
- Pointer Saved_Expression = Fetch_Expression();
- long Saved_Return_Code = Fetch_Return();
-
-Will_Push(HISTORY_SIZE);
- Save_History(RC_RESTORE_DONT_COPY_HISTORY);
-Pushed();
- Prev_Restore_History_Stacklet = NULL;
- Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - Stack_Pointer) +
- CONTINUATION_RETURN_CODE);
- Store_Expression(Saved_Expression);
- Store_Return(Saved_Return_Code);
- return;
-}
-
-Pointer *
-Copy_Rib (Orig_Rib)
- Pointer *Orig_Rib;
-{
- Pointer *Result, *This_Rib;
-
- for (This_Rib=NULL, Result=Free;
- (This_Rib != Orig_Rib) && (!GC_Check(0));
- This_Rib = Get_Pointer(This_Rib[RIB_NEXT_REDUCTION]))
- { if (This_Rib==NULL) This_Rib = Orig_Rib;
- Free[RIB_EXP] = This_Rib[RIB_EXP];
- Free[RIB_ENV] = This_Rib[RIB_ENV];
- Free[RIB_NEXT_REDUCTION] = Make_Pointer(TC_HUNK3, Free+3);
- if (Dangerous(This_Rib[RIB_MARK])) Free[RIB_MARK] |= DANGER_BIT;
- Free += 3;
- }
- Store_Address((Free-3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result));
- return Result;
-}
-\f
-/* Restore_History pops a history object off the stack and
- makes a COPY of it the current history collection object.
- This is called only from the RC_RESTORE_HISTORY case in
- interpret.c .
-*/
-
-Boolean
-Restore_History (Hist_Obj)
- Pointer Hist_Obj;
-{
- Pointer *New_History, *Next_Vertebra, *Prev_Vertebra,
- *Orig_Vertebra;
-
- if (Consistency_Check)
- if (Type_Code(Hist_Obj) != TC_HUNK3)
- { printf("Bad history to restore.\n");
- Microcode_Termination(TERM_EXIT);
- }
- Orig_Vertebra = Get_Pointer(Hist_Obj);
- for (Next_Vertebra=NULL, Prev_Vertebra=NULL;
- Next_Vertebra != Orig_Vertebra;
- Next_Vertebra =
- Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM]))
- { Pointer *New_Rib;
- if (Prev_Vertebra==NULL) Next_Vertebra = Orig_Vertebra;
- New_Rib = Copy_Rib(Get_Pointer(Next_Vertebra[HIST_RIB]));
- if (Prev_Vertebra==NULL) New_History = Free;
- else Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(TC_HUNK3, Free);
- Free[HIST_RIB] = Make_Pointer(TC_HUNK3, New_Rib);
- Free[HIST_NEXT_SUBPROBLEM] = NIL;
- Free[HIST_PREV_SUBPROBLEM] =
- Make_Pointer(TC_HUNK3, Prev_Vertebra);
- if (Dangerous(Next_Vertebra[HIST_MARK]))
- Free[HIST_MARK] |= DANGER_BIT;
- Prev_Vertebra = Free;
- Free += 3;
- if (GC_Check(0)) return false;
- }
- Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3));
- Prev_Vertebra[HIST_NEXT_SUBPROBLEM] =
- Make_Pointer(TC_HUNK3, New_History);
- if (Dangerous(Orig_Vertebra[HIST_MARK]))
- Prev_Vertebra[HIST_MARK] |= DANGER_BIT;
- History = New_History;
- return true;
-}
-
-CRLF ()
-{
- printf( "\n");
-}
-\f
-/* If a debugging version of the interpreter is made, then this
- * procedure is called to actually invoke a primitive. When a
- * 'production' version is made, all of the consistency checks are
- * omitted and a macro from DEFAULT.H is used to directly code the
- * call to the primitive function. This is only used in INTERPRET.C.
- */
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-Pointer
-Apply_Primitive (Primitive_Number)
- long Primitive_Number;
-{
- Pointer Result, *Saved_Stack;
- int NArgs;
-
- if (Primitive_Number > MAX_PRIMITIVE)
- {
- Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
- }
- if (Primitive_Debug)
- {
- Print_Primitive(Primitive_Number);
- }
- NArgs = N_Args_Primitive(Primitive_Number);
- Saved_Stack = Stack_Pointer;
- Result = Internal_Apply_Primitive(Primitive_Number);
- if (Saved_Stack != Stack_Pointer)
- {
- Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number),
- "Stack bad after ");
- fprintf(stderr,
- "\nStack was 0x%x, now 0x%x, #args=%d.\n",
- Saved_Stack, Stack_Pointer, NArgs);
- Microcode_Termination(TERM_EXIT);
- }
- if (Primitive_Debug)
- {
- Print_Expression(Result, "Primitive Result");
- fprintf(stderr, "\n");
- }
- return Result;
-}
-#endif
-\f
-Pointer
-Allocate_Float (F)
- double F;
-{
- Pointer Result;
-
- Align_Float(Free);
- Result = Make_Pointer(TC_BIG_FLONUM, Free);
- *Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE);
- Get_Float(C_To_Scheme(Free)) = F;
- Primitive_GC_If_Needed(FLONUM_SIZE+1);
- Free += FLONUM_SIZE+1;
- return Result;
-}
-\f
-#ifdef USE_STACKLETS
- /******************/
- /* STACKLETS */
- /******************/
-
-void
-Allocate_New_Stacklet (N)
- long N;
-{
- Pointer Old_Expression, *Old_Stacklet, Old_Return;
-
- Old_Stacklet = Current_Stacklet;
- Terminate_Old_Stacklet();
- if ((Free_Stacklets == NULL) ||
- ((N+STACKLET_SLACK) > Get_Integer(Free_Stacklets[STACKLET_LENGTH])))
- { long size = New_Stacklet_Size(N);
- /* Room is set aside for the two header bytes of a stacklet plus
- * the two bytes required for the RC_JOIN_STACKLETS frame.
- */
- if (GC_Check(size))
- { Request_GC(size);
- if (Free+size >= Heap_Top)
- Microcode_Termination(TERM_STACK_OVERFLOW);
- }
- Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, size-1);
- Stack_Guard = &(Free[STACKLET_HEADER_SIZE]);
- Free += size;
- Stack_Pointer = Free;
- }
- else /* Grab first one on the free list */
- { Pointer *New_Stacklet = Free_Stacklets;
- Free_Stacklets = ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]);
- Stack_Pointer =
- &New_Stacklet[1 + Get_Integer(New_Stacklet[STACKLET_LENGTH])];
- Stack_Guard = &New_Stacklet[STACKLET_HEADER_SIZE];
- }
- Old_Expression = Fetch_Expression();
- Old_Return = Fetch_Return();
- Store_Expression(Make_Pointer(TC_CONTROL_POINT, Old_Stacklet));
- Store_Return(RC_JOIN_STACKLETS);
-/* Will_Push omitted because size calculation includes enough room. */
- Save_Cont();
- Store_Expression(Old_Expression);
- Store_Return(Old_Return);
- return;
-}
-#endif
-\f
-/* Dynamic Winder support code */
-
-Pointer
-Find_State_Space (State_Point)
- Pointer State_Point;
-{
- long How_Far = Get_Integer(Fast_Vector_Ref(State_Point,
- STATE_POINT_DISTANCE_TO_ROOT));
- long i;
- fast Pointer Point = State_Point;
-
- for (i=0; i <= How_Far; i++)
- {
-#ifdef ENABLE_DEBUGGING_TOOLS
- if (Point == NIL)
- { printf("\nState_Point 0x%x wrong: count was %d, NIL at %d\n",
- State_Point, How_Far, i);
- Microcode_Termination(TERM_EXIT);
- }
-#endif
- Point = Fast_Vector_Ref(Point, STATE_POINT_NEARER_POINT);
- }
- return Point;
-}
-
-/* ASSUMPTION: State points, which are created only by the interpreter,
- never contain FUTUREs except possibly as the thunks (which are handled
- by the apply code).
-
- Furthermore:
- (1) On a single processor, things should work with multiple state
- spaces. The microcode variable Current_State_Point tracks
- the location in the "boot" space (i.e. the one whose space is
- NIL) and the state spaces themselves (roots of the space
- trees) track the other spaces.
- (2) On multi-processors, multiple spaces DO NOT work. Only the
- initial space (NIL) is tracked by the microcode (it is
- swapped on every task switch), but no association with trees
- is kept. This will work since the initial tree has no space
- at the root, indicating that the microcode variable rather
- than the state space contains the current state space
- location.
-*/
-\f
-void
-Translate_To_Point (Target)
- Pointer Target;
-{
- Pointer State_Space = Find_State_Space(Target);
- Pointer Current_Location, *Path = Free;
- fast Pointer Path_Point, *Path_Ptr;
- long Distance, Merge_Depth, From_Depth, i;
-
- guarantee_state_point();
- Distance =
- Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT));
- if (State_Space == NIL)
- Current_Location = Current_State_Point;
- else
- Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
- if (Target == Current_Location)
- longjmp(*Back_To_Eval, PRIM_POP_RETURN);
- for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0;
- i <= Distance;
- i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
- *Path_Ptr-- = Path_Point;
- From_Depth =
- Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT));
- for (Path_Point=Current_Location, Merge_Depth = From_Depth;
- Merge_Depth > Distance;
- Merge_Depth--)
- Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
- for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0;
- Merge_Depth--, Path_Ptr--,
- Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
- if (*Path_Ptr == Path_Point)
- break;
-#ifdef ENABLE_DEBUGGING_TOOLS
- if (Merge_Depth < 0)
- {
- fprintf(stderr, "\nMerge_Depth went negative: %d\n", Merge_Depth);
- Microcode_Termination(TERM_EXIT);
- }
-#endif
- Will_Push(2*CONTINUATION_SIZE + 4);
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- Save_Cont();
- Push(Make_Unsigned_Fixnum((Distance-Merge_Depth)));
- Push(Target);
- Push(Make_Unsigned_Fixnum((From_Depth-Merge_Depth)));
- Push(Current_Location);
- Store_Expression(State_Space);
- Store_Return(RC_MOVE_TO_ADJACENT_POINT);
- Save_Cont();
- Pushed();
- IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */
- longjmp(*Back_To_Eval, PRIM_POP_RETURN);
- /*NOTREACHED*/
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.22 1987/04/16 02:32:44 jinx Exp $
- *
- * This file contains procedures for handling vectors and conversion
- * back and forth to lists.
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
- /*********************/
- /* VECTORS <-> LISTS */
- /*********************/
-
-/* Subvector_To_List is a utility routine used by both
- SUBVECTOR_TO_LIST and SYS_SUBVECTOR_TO_LIST. It copies the entries
- in a vector (first argument) starting with the entry specified by
- argument 2 and ending at the one specified by argument 3. The copy
- includes the starting entry but does NOT include the ending entry.
- Thus the entire vector is converted to a list by setting argument 2
- to 0 and argument 3 to the length of the vector.
-*/
-
-Pointer Subvector_To_List()
-{ Pointer *From, Result;
- long Length, Start, End, Count, i;
- Primitive_3_Args();
- if (Type_Code(Arg2) != TC_FIXNUM) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- if (Type_Code(Arg3) != TC_FIXNUM) Primitive_Error(ERR_ARG_3_WRONG_TYPE);
- if (Type_Code(Vector_Ref(Arg1, VECTOR_TYPE)) != TC_MANIFEST_VECTOR)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Length = Vector_Length(Arg1);
- Start = Get_Integer(Arg2);
- End = Get_Integer(Arg3);
- if (End > Length) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Start > End) Primitive_Error(ERR_ARG_3_BAD_RANGE);
- if (Start == End) return NIL;
- Primitive_GC_If_Needed(2*(End-Start));
- Result = Make_Pointer(TC_LIST, Free);
- From = Nth_Vector_Loc(Arg1, Start+1);
- Count = End-Start;
- for (i=0; i < Count; i++)
- { *Free++ = Fetch(*From++);
- *Free = Make_Pointer(TC_LIST, Free+1);
- Free += 1;
- }
- Free[-1] = NIL;
- return Result;
-}
-\f
-/* Called by the primitives LIST_TO_VECTOR and SYS_LIST_TO_VECTOR.
- This utility routine converts a list into a vector.
-*/
-
-Pointer L_To_V(Result_Type, List)
-long Result_Type;
-fast Pointer List;
-{ Pointer *Orig_Free;
- long Count;
- Touch_In_Primitive(List, List);
- Count = 0;
- Orig_Free = Free++;
- while (Type_Code(List) == TC_LIST)
- { Primitive_GC_If_Needed(0);
- Count += 1;
- *Free++ = Vector_Ref(List, CONS_CAR);
- Touch_In_Primitive(Vector_Ref(List, CONS_CDR), List);
- }
- if (List != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- *Orig_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
- return Make_Pointer(Result_Type, Orig_Free);
-}
-
-/* (LIST->VECTOR LIST)
- Returns a vector made from the items in LIST.
-*/
-
-Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR", 0x7C)
-{
- Primitive_1_Arg();
-
- return L_To_V(TC_VECTOR, Arg1);
-}
-\f
-/* (SUBVECTOR->LIST VECTOR FROM TO)
- Returns a list of the FROMth through TO-1st items in the vector.
- Thus (SUBVECTOR_TO_LIST V 0 (VECTOR_LENGTH V)) returns a list of
- all the items in V.
-*/
-Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST", 0x7D)
-{
- Primitive_3_Args();
-
- Arg_1_Type(TC_VECTOR);
- return Subvector_To_List();
-}
-
-/* (VECTOR_CONS LENGTH CONTENTS)
- Create a new vector to hold LENGTH entries, all of which are
- initialized to CONTENTS.
-*/
-Built_In_Primitive(Prim_Vector_Cons, 2, "VECTOR-CONS", 0x2C)
-{
- long Length, i;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Length = Get_Integer(Arg1);
- Primitive_GC_If_Needed(Length+1);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
- for (i = 0; i < Length; i++)
- *Free++ = Arg2;
- return Make_Pointer(TC_VECTOR, (Free - (Length + 1)));
-}
-
-/* (VECTOR-REF VECTOR OFFSET)
- Return the OFFSETth entry in VECTOR. Entries are numbered from 0.
-*/
-Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF", 0x2E)
-{
- long Offset;
- Primitive_2_Args();
-
- Arg_1_Type(TC_VECTOR);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2,
- 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
- return User_Vector_Ref(Arg1, Offset);
-}
-\f
-/* (VECTOR-SET! VECTOR OFFSET VALUE)
- Store VALUE as the OFFSETth entry in VECTOR. Entries are
- numbered from 0. Returns (bad style to rely on this) the
- previous value of the entry.
-*/
-Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!", 0x30)
-{
- long Offset;
- Primitive_3_Args();
-
- Arg_1_Type(TC_VECTOR);
- Arg_2_Type(TC_FIXNUM);
- Range_Check(Offset, Arg2,
- 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
- Side_Effect_Impurify(Arg1, Arg3);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3);
-}
-
-/* (VECTOR-LENGTH VECTOR)
- Returns the number of entries in VECTOR.
-*/
-Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-LENGTH", 0x2D)
-{
- Primitive_1_Arg();
-
- Arg_1_Type(TC_VECTOR);
- return Make_Unsigned_Fixnum(Vector_Length(Arg1));
-}
-\f
-/* (SYSTEM-LIST-TO-VECTOR GC-LIST)
- Same as LIST_TO_VECTOR except that the resulting vector has the
- specified type code. This can be used, for example, to create
- an environment from a list of values.
-*/
-Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST-TO-VECTOR", 0x97)
-{
- long Type;
- Primitive_2_Args();
-
- Arg_1_Type(TC_FIXNUM);
- Range_Check(Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE);
- if (GC_Type_Code(Type) == GC_Vector)
- return L_To_V(Type, Arg2);
- else
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- /*NOTREACHED*/
-}
-
-/* (SYSTEM-SUBVECTOR-TO-LIST GC-VECTOR FROM TO)
- Same as SUBVECTOR->LIST, but accepts anything with a GC type
- of VECTOR.
-*/
-Built_In_Primitive(Prim_Sys_Subvector_To_List, 3,
- "SYSTEM-SUBVECTOR-TO-LIST", 0x98)
-{
- Primitive_3_Args();
- Touch_In_Primitive(Arg1, Arg1);
-
- Arg_1_GC_Type(GC_Vector);
- return Subvector_To_List();
-}
-\f
-/* (SYSTEM-VECTOR? OBJECT)
- Returns #!TRUE if OBJECT is of GC type VECTOR. Otherwise
- returns NIL.
-*/
-Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR?", 0x99)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- if (GC_Type_Vector(Arg1))
- return TRUTH;
- else
- return NIL;
-}
-
-/* (SYSTEM-VECTOR-REF GC-VECTOR OFFSET)
- Like VECTOR_REF, but for anything of GC type VECTOR.
-*/
-Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF", 0x9A)
-{
- long Offset;
- Primitive_2_Args();
-
- Touch_In_Primitive(Arg1, Arg1);
- Arg_1_GC_Type(GC_Vector);
- Range_Check(Offset, Arg2, 0,
- (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
- return User_Vector_Ref(Arg1, Offset);
-}
-
-/* (SYSTEM-VECTOR-SET! GC-VECTOR OFFSET VALUE)
- Like VECTOR_SET, but for anything of GC type VECTOR.
-*/
-Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!", 0x9B)
-{
- long Offset;
- Primitive_3_Args();
-
- Touch_In_Primitive(Arg1, Arg1);
- Arg_1_GC_Type(GC_Vector);
- Range_Check(Offset, Arg2, 0,
- Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
- Side_Effect_Impurify(Arg1, Arg3);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3);
-}
-\f
-/* (SYSTEM-VECTOR-SIZE GC-VECTOR)
- Like VECTOR_SIZE, but for anything of GC type VECTOR.
-*/
-Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE", 0xAE)
-{
- Primitive_1_Arg();
-
- Touch_In_Primitive(Arg1, Arg1);
- Arg_1_GC_Type(GC_Vector);
- return Make_Unsigned_Fixnum(Vector_Length(Arg1));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.41 1987/04/17 04:03:23 cph Exp $
-
-This file contains version information for the microcode. */
-\f
-/* Scheme system release version */
-
-#ifndef RELEASE
-#define RELEASE "5.0.20"
-#endif
-
-/* Microcode release version */
-
-#ifndef VERSION
-#define VERSION 9
-#endif
-#ifndef SUBVERSION
-#define SUBVERSION 41
-#endif
-
-#ifndef UCODE_TABLES_FILENAME
-#define UCODE_TABLES_FILENAME "utabmd.bin"
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/winder.h,v 9.22 1987/04/16 02:33:24 jinx Rel $
-
- Header file for dynamic winder.
-
-*/
-\f
-#ifdef butterfly
-
-#define guarantee_state_point() \
-{ \
- if (Current_State_Point == NIL) \
- Current_State_Point = Get_Fixed_Obj_Slot( State_Space_Root); \
-}
-
-#else
-
-#define guarantee_state_point()
-
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/wsize.c,v 9.21 1987/01/22 14:14:27 jinx Exp $ */
-\f
-#include <stdio.h>
-#include <math.h>
-#include <errno.h>
-
-extern int errno;
-extern char *malloc();
-extern free();
-
-/* Some machines do not set ERANGE by default. */
-/* This attempts to fix this. */
-
-#ifdef celerity
-#define hack_signal
-#endif
-
-#ifdef hack_signal
-#define setup_error() signal(SIGFPE, range_error)
-
-range_error()
-{ setup_error();
- errno = ERANGE;
-}
-#else
-#define setup_error()
-#endif
-
-
-#define ARR_SIZE 20000
-#define MEM_SIZE 400000
-
-/* Force program data to be relatively large. */
-
-static long dummy[ARR_SIZE];
-
-/* Note: comments are printed in a weird way because some
- C compilers eliminate them even from strings.
-*/
-
-main()
-{ double accum, delta;
- int count, expt_size, char_size, mant_size;
- unsigned long to_be_shifted;
- unsigned bogus;
- char *temp;
-
- setup_error();
- for(bogus = ((unsigned) -1), count = 0;
- bogus != 0;
- count += 1)
- bogus >>= 1;
-
- char_size = count/(sizeof(unsigned));
- temp = malloc(MEM_SIZE*sizeof(long));
- if (temp == NULL)
- printf("/%c Cannot allocate %d Pointers. %c/\n",
- '*', MEM_SIZE, '*');
- else count = free(temp);
-
- if (((unsigned long) temp) < (1 << ((char_size*sizeof(long))-8)))
- printf("#define Heap_In_Low_Memory\n");
- else
- printf("/%c Heap is not in Low Memory. %c/\n", '*', '*');
-
- to_be_shifted = -1;
- if ((to_be_shifted >> 1) != to_be_shifted)
- printf("#define UNSIGNED_SHIFT\n");
- else
- printf("/%c unsigned longs use arithmetic shifting. %c/\n",
- '*', '*');
-
- printf("#define CHAR_SIZE %d\n",
- char_size);
-
- printf("#define USHORT_SIZE %d\n",
- (sizeof(unsigned short) * char_size));
-
- printf("#define ULONG_SIZE %d\n",
- (sizeof(unsigned long) * char_size));
-
- printf("/%c Flonum (double) size is %d bits. %c/\n",
- '*', (char_size*sizeof(double)), '*');
-
- for(mant_size = 0, accum = 1.0, delta = 0.5;
- ((accum + delta) != accum);
- accum = accum + delta,
- delta /= 2.0,
- mant_size += 1) ;
-
- for(errno = 0, expt_size = 0, bogus = 1;
- errno != ERANGE;
- expt_size += 1, bogus <<= 1)
- accum = pow(2.0, ((double) bogus));
-
- expt_size -= 1;
-
- printf("#define FLONUM_EXPT_SIZE %d\n", expt_size);
- printf("#define FLONUM_MANTISSA_BITS %d\n", mant_size);
- printf("#define MAX_FLONUM_EXPONENT %d\n", ((1 << expt_size) - 1));
- printf("/%c Representation %s hidden bit. %c/\n", '*',
- (((2+expt_size+mant_size) > (char_size*sizeof(double))) ?
- "uses" :
- "does not use"), '*');
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.21 1987/01/22 14:37:28 jinx Rel $
- *
- * This file contains primitives to debug the memory management in the
- * Scheme system.
- *
- */
-
-#include "scheme.h"
-#include "primitive.h"
-\f
-/* New debugging utilities */
-
-#define FULL_EQ 0
-#define SAFE_EQ 1
-#define ADDRESS_EQ 2
-#define DATUM_EQ 3
-
-#define SAFE_MASK (~DANGER_BIT)
-
-static Pointer *Find_Occurrence(From, To, What, Mode)
-fast Pointer *From, *To;
-Pointer What;
-int Mode;
-{ fast Pointer Obj;
- switch (Mode)
- { default:
- case FULL_EQ:
- { Obj = What;
- for (; From < To; From++)
- if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- else if (*From == Obj) return From;
- return To;
- }
- case SAFE_EQ:
- { Obj = (What & SAFE_MASK);
- for (; From < To; From++)
- if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- else if (((*From) & SAFE_MASK) == Obj) return From;
- return To;
- }
- case ADDRESS_EQ:
- { Obj = Datum(What);
- for (; From < To; From++)
- if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- else if ((Datum(*From) == Obj) &&
- (!(GC_Type_Non_Pointer(*From))))
- return From;
- return To;
- }
- case DATUM_EQ:
- { Obj = Datum(What);
- for (; From < To; From++)
- if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- else if (Datum(*From) == Obj) return From;
- return To;
- }
- }
-}
-\f
-static long Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p)
-char *Name;
-Pointer *From, *To, Obj;
-int Mode;
-Boolean print_p, store_p;
-{ fast Pointer *Where;
- fast long occurrences = 0;
- if (print_p) printf(" Looking in %s:\n", Name);
- Where = From-1;
- while ((Where = Find_Occurrence(Where+1, To, Obj, Mode)) < To)
- { occurrences += 1;
- if (print_p)
-#ifndef b32
- printf("Location = 0x%x; Contents = 0x%x\n",
- ((long) Where), ((long) (*Where)));
-#else
- printf("Location = 0x%08x; Contents = 0x%08x\n",
- ((long) Where), ((long) (*Where)));
-#endif
- if (store_p)
- /* Note that Make_Pointer (vs. Make_Non_Pointer) is correct here!! */
- *Free++ = Make_Pointer(TC_ADDRESS, Where);
- }
- return occurrences;
-}
-
-#define PRINT_P 1
-#define STORE_P 2
-
-Pointer Find_Who_Points(Obj, Find_Mode, Collect_Mode)
-Pointer Obj;
-int Find_Mode, Collect_Mode;
-{ long n = 0;
- Pointer *Saved_Free = Free;
- Boolean print_p = (Collect_Mode & PRINT_P);
- Boolean store_p = (Collect_Mode & STORE_P);
- /* No overflow check done. Hopefully referenced few times, or invoked before
- to find the count and insure that there is enough space. */
- if (store_p) Free += 1;
- if (print_p)
- { putchar('\n');
-#ifndef b32
- printf("*** Looking for Obj = 0x%x; Find_Mode = %2d ***\n",
- Obj, Find_Mode);
-#else
- printf("*** Looking for Obj = 0x%08x; Find_Mode = %2d ***\n",
- Obj, Find_Mode);
-#endif
- }
- n += Find_In_Area("Constant Space",
- Constant_Space, Free_Constant, Obj,
- Find_Mode, print_p, store_p);
- n += Find_In_Area("the Heap",
- Heap_Bottom, Saved_Free, Obj,
- Find_Mode, print_p, store_p);
-#ifndef USE_STACKLETS
- n += Find_In_Area("the Stack",
- Stack_Pointer, Stack_Top, Obj,
- Find_Mode, print_p, store_p);
-#endif
- if (print_p) printf("Done.\n");
- if (store_p)
- { *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n);
- return Make_Pointer(TC_VECTOR, Saved_Free);
- }
- else return Make_Non_Pointer(TC_FIXNUM, n);
-}
-\f
-Print_Memory(Where, How_Many)
-Pointer *Where;
-long How_Many;
-{ fast Pointer *End = &Where[How_Many];
-#ifndef b32
- printf("\n*** Memory from 0x%x to 0x%x (excluded) ***\n", Where, End);
- while (Where < End) printf("0x%x\n", *Where++);
-#else
- printf("\n*** Memory from 0x%08x to 0x%08x (excluded) ***\n", Where, End);
- while (Where < End) printf("0x%08x\n", *Where++);
-#endif
- printf("Done.\n");
- return;
-}
-\f
-/* Primitives to give scheme a handle on utilities from DEBUG.C */
-
-Define_Primitive(Prim_Show_Pure, 0, "SHOW-PURE")
-{ printf("\n*** Constant & Pure Space: ***\n");
- Show_Pure();
- return TRUTH;
-}
-
-Define_Primitive(Prim_Show_Env, 1, "SHOW-ENV")
-{ Primitive_1_Arg();
- printf("\n*** Environment = 0x%x ***\n", Arg1);
- Show_Env(Arg1);
- return TRUTH;
-}
-
-Define_Primitive(Prim_Stack_Trace, 0, "STACK-TRACE")
-{ Primitive_0_Args();
- printf("\n*** Back Trace: ***\n");
- Back_Trace();
- return TRUTH;
-}
-
-Define_Primitive(Prim_Find_Symbol, 1, "FIND-SYMBOL")
-{ Primitive_1_Arg();
- Find_Symbol();
- return TRUTH;
-}
-\f
-/* Primitives to give scheme a handle on utilities on this file. */
-
-Define_Primitive(Prim_Debug_Flags, 0, "DEBUG-FLAGS")
-{ Handle_Debug_Flags();
- return TRUTH;
-}
-
-Define_Primitive(Prim_Find_Who_Points, 3, "FIND-WHO-POINTS")
-{ Primitive_3_Args();
- return Find_Who_Points(Arg1, Get_Integer(Arg2), Get_Integer(Arg3));
-}
-
-Define_Primitive(Prim_Print_Memory, 2, "PRINT-MEMORY")
-{ Pointer *Base;
- Primitive_2_Args();
- if (GC_Type_Non_Pointer(Arg1))
- Base = ((Pointer *) Datum(Arg1));
- else Base = Get_Pointer(Arg1);
- Print_Memory(Base, Get_Integer(Arg2));
- return TRUTH;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/zones.h,v 9.21 1987/01/22 14:37:35 jinx Exp $
- *
- * Metering stuff.
- * We break all times into time zones suitable for external analysis.
- * Primitives may be included for accessing this information if desired
- * by supplying additional files.
- */
-\f
-#ifdef METERING
-extern long New_Time, Old_Time, Time_Meters[], Current_Zone;
-
-#ifdef ENABLE_DEBUGGING_TOOLS
-#define Set_Time_Zone(Zone) \
-{ New_Time = Sys_Clock();\
- Time_Meters[Current_Zone] += New_Time-Old_Time;\
- Old_Time = New_Time;\
- Current_Zone = Zone;\
-}
-#else
-#define Set_Time_Zone(Zone) Current_Zone = Zone;
-#endif
-
-#define Save_Time_Zone(Zone) Saved_Zone = Current_Zone; Set_Time_Zone(Zone);
-#define Restore_Time_Zone() Set_Time_Zone(Saved_Zone);
-#else
-#define Set_Time_Zone(Zone)
-#define Save_Time_Zone(Zone)
-#define Restore_Time_Zone()
-#endif
-
-#define Zone_Working 0
-#define Zone_GetWork 1
-#define Zone_TTY_IO 2
-#define Zone_Disk_IO 3
-#define Zone_Purify 4
-#define Zone_GCLoop 5
-#define Zone_Global_Int 6
-#define Zone_Store_Lock 7
-#define Zone_Math 8
-#define Zone_GCIdle 9
-#define Zone_Lookup 10
-
-/* For finding out about lock contention - 1/19/87 - sas */
-
-#define Zone_Count_Locks 11
-#define Zone_Count_Lock_0 12
-#define Zone_Count_Lock_1 13
-#define Zone_Count_Lock_2 14
-#define Zone_Count_Lock_3 15
-#define Zone_Count_Lock_4 16
-#define Zone_Count_Lock_5 17
-#define Zone_Count_Lock_6 18
-#define Zone_Count_Lock_N 19
-
-#define Max_Meters 20
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 13.42 1987/03/17 18:48:26 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Advice package
-
-(declare (usual-integrations))
-\f
-(define advice-package
- (make-environment
-
-(define the-args)
-(define the-procedure)
-(define the-result)
-
-(define (*args*)
- the-args)
-
-(define (*proc*)
- the-procedure)
-
-(define (*result*)
- the-result)
-
-(define entry-advice-population
- (make-population))
-
-(define exit-advice-population
- (make-population))
-\f
-;;;; Advice Wrappers
-
-(define (add-lambda-advice! lambda advice-transformation)
- ((access lambda-wrap-body! lambda-package) lambda
- (lambda (body state cont)
- (if (null? state)
- (cont (make-advice-hook)
- (advice-transformation '() '() cons))
- (cont body
- (advice-transformation (car state) (cdr state) cons))))))
-
-(define (remove-lambda-advice! lambda advice-transformation)
- (lambda-advice lambda
- (lambda (entry-advice exit-advice)
- (advice-transformation entry-advice exit-advice
- (lambda (new-entry-advice new-exit-advice)
- (if (and (null? new-entry-advice)
- (null? new-exit-advice))
- ((access lambda-unwrap-body! lambda-package) lambda)
- ((access lambda-wrap-body! lambda-package) lambda
- (lambda (body state cont)
- (cont body (cons new-entry-advice new-exit-advice))))))))))
-
-(define (lambda-advice lambda cont)
- ((access lambda-wrapper-components lambda-package) lambda
- (lambda (original-body state)
- (if (null? state)
- (error "Procedure has no advice -- LAMBDA-ADVICE" lambda)
- (cont (car state)
- (cdr state))))))
-
-(define (make-advice-hook)
- (make-combination syntaxed-advice-procedure
- (list (make-the-environment))))
-
-(define syntaxed-advice-procedure
- (scode-quote
- (ACCESS ADVISED-PROCEDURE-WRAPPER ADVICE-PACKAGE '())))
-\f
-;;;; The Advice Hook
-
-;;; This procedure is called with the newly-created environment as its
-;;; argument.
-
-;;; Doing (PROCEED) from within entry or exit advice will cause that
-;;; particular piece of advice to be terminated, but any remaining
-;;; advice to be executed. Doing (PROCEED value), however,
-;;; immediately terminates all advice and returns VALUE as if the
-;;; procedure called had generated the value. Returning from a piece
-;;; of exit advice is equivalent to doing (PROCEED value) from it.
-
-(define (advised-procedure-wrapper environment)
- (let ((procedure (environment-procedure environment))
- (arguments (environment-arguments environment)))
- ((access lambda-wrapper-components lambda-package)
- (procedure-lambda procedure)
- (lambda (original-body state)
- (call-with-current-continuation
- (lambda (continuation)
-
- (define ((catching-proceeds receiver) advice)
- (with-proceed-point
- (lambda (value)
- (if (null? value)
- '()
- (continuation (car value))))
- (lambda ()
- (receiver advice))))
-
- (for-each (catching-proceeds
- (lambda (advice)
- (advice procedure arguments environment)))
- (car state))
- (let ((value (scode-eval original-body environment)))
- (for-each (catching-proceeds
- (lambda (advice)
- (set! value
- (advice procedure
- arguments
- value
- environment))))
- (cdr state))
- value)))))))
-\f
-;;;; Primitive Advisors
-
-(define (primitive-advice lambda)
- (lambda-advice lambda list))
-
-(define (primitive-entry-advice lambda)
- (lambda-advice lambda
- (lambda (entry-advice exit-advice)
- entry-advice)))
-
-(define (primitive-exit-advice lambda)
- (lambda-advice lambda
- (lambda (entry-advice exit-advice)
- exit-advice)))
-
-(define (primitive-advise-entry lambda advice)
- (add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont (if (memq advice entry-advice)
- entry-advice
- (cons advice entry-advice))
- exit-advice)))
- (add-to-population! entry-advice-population lambda))
-
-(define (primitive-advise-exit lambda advice)
- (add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont entry-advice
- (if (memq advice exit-advice)
- exit-advice
- (append! exit-advice (list advice))))))
- (add-to-population! exit-advice-population lambda))
-
-(define ((primitive-advise-both new-entry-advice new-exit-advice) lambda)
- (add-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont (if (memq new-entry-advice entry-advice)
- entry-advice
- (cons new-entry-advice entry-advice))
- (if (memq new-exit-advice exit-advice)
- exit-advice
- (append! exit-advice (list new-exit-advice))))))
- (add-to-population! entry-advice-population lambda)
- (add-to-population! exit-advice-population lambda))
-
-(define (eq?-adjoin object list)
- (if (memq object list)
- list
- (cons object list)))
-\f
-(define (primitive-unadvise-entire-entry lambda)
- (remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont '() exit-advice)))
- (remove-from-population! entry-advice-population lambda))
-
-(define (primitive-unadvise-entire-exit lambda)
- (remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (cont entry-advice '())))
- (remove-from-population! exit-advice-population lambda))
-
-(define (primitive-unadvise-entire-lambda lambda)
- ((access lambda-unwrap-body! lambda-package) lambda)
- (remove-from-population! entry-advice-population lambda)
- (remove-from-population! exit-advice-population lambda))
-
-(define ((primitive-unadvise-entry advice) lambda)
- (remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (let ((new-entry-advice (delq! advice entry-advice)))
- (if (null? new-entry-advice)
- (remove-from-population! entry-advice-population lambda))
- (cont new-entry-advice exit-advice)))))
-
-(define ((primitive-unadvise-exit advice) lambda)
- (remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (let ((new-exit-advice (delq! advice exit-advice)))
- (if (null? new-exit-advice)
- (remove-from-population! exit-advice-population lambda))
- (cont entry-advice new-exit-advice)))))
-
-(define ((primitive-unadvise-both old-entry-advice old-exit-advice) lambda)
- (remove-lambda-advice! lambda
- (lambda (entry-advice exit-advice cont)
- (let ((new-entry-advice (delq! old-entry-advice entry-advice))
- (new-exit-advice (delq! old-exit-advice exit-advice)))
- (if (null? new-entry-advice)
- (remove-from-population! entry-advice-population lambda))
- (if (null? new-exit-advice)
- (remove-from-population! exit-advice-population lambda))
- (cont new-entry-advice new-exit-advice)))))
-
-(define (((particular-advisor advisor) advice) lambda)
- (advisor lambda advice))
-
-(define particular-entry-advisor (particular-advisor primitive-advise-entry))
-(define particular-exit-advisor (particular-advisor primitive-advise-exit))
-(define particular-both-advisor primitive-advise-both)
-(define particular-entry-unadvisor primitive-unadvise-entry)
-(define particular-exit-unadvisor primitive-unadvise-exit)
-(define particular-both-unadvisor primitive-unadvise-both)
-\f
-;;;; Trace
-
-(define (trace-entry-advice proc args env)
- (trace-display proc args))
-
-(define (trace-exit-advice proc args result env)
- (trace-display proc args result)
- result)
-
-(define (trace-display proc args #!optional result)
- (newline)
- (let ((width (- (access printer-width implementation-dependencies) 3)))
- (let ((output
- (with-output-to-truncated-string
- width
- (lambda ()
- (if (unassigned? result)
- (write-string "[Entering ")
- (begin (write-string "[")
- (write result)
- (write-string " <== ")))
- (write-string "<")
- (write proc)
- (for-each (lambda (arg) (write-char #\Space) (write arg))
- args)))))
- (if (car output) ; Too long?
- (begin
- (write-string (substring (cdr output) 0 (- width 5)))
- (write-string " ... "))
- (write-string (cdr output)))))
- (write-string ">]"))
-
-(define primitive-trace-entry
- (particular-entry-advisor trace-entry-advice))
-
-(define primitive-trace-exit
- (particular-exit-advisor trace-exit-advice))
-
-(define primitive-trace-both
- (particular-both-advisor trace-entry-advice trace-exit-advice))
-
-(define primitive-untrace
- (particular-both-unadvisor trace-entry-advice trace-exit-advice))
-
-(define primitive-untrace-entry
- (particular-entry-unadvisor trace-entry-advice))
-
-(define primitive-untrace-exit
- (particular-exit-unadvisor trace-exit-advice))
-\f
-;;;; Break
-
-(define (break-rep env message . info)
- (push-rep env
- (lambda ()
- (apply trace-display info)
- ((standard-rep-message message)))
- (standard-rep-prompt breakpoint-prompt)))
-
-(define (break-entry-advice proc args env)
- (fluid-let ((the-procedure proc)
- (the-args args))
- (break-rep env "Breakpoint on entry" proc args)))
-
-(define (break-exit-advice proc args result env)
- (fluid-let ((the-procedure proc)
- (the-args args)
- (the-result result))
- (break-rep env "Breakpoint on exit" proc args result))
- result)
-
-(define primitive-break-entry
- (particular-entry-advisor break-entry-advice))
-
-(define primitive-break-exit
- (particular-exit-advisor break-exit-advice))
-
-(define primitive-break-both
- (particular-both-advisor break-entry-advice break-exit-advice))
-
-(define primitive-unbreak
- (particular-both-unadvisor break-entry-advice break-exit-advice))
-
-(define primitive-unbreak-entry
- (particular-entry-unadvisor break-entry-advice))
-
-(define primitive-unbreak-exit
- (particular-exit-unadvisor break-exit-advice))
-\f
-;;;; Top Level Wrappers
-
-(define (find-internal-lambda procedure path)
- (define (find-lambda lambda path)
- (define (loop elements)
- (cond ((null? elements)
- (error "Couldn't find internal definition" path))
- ((definition? (car elements))
- (definition-components (car elements)
- (lambda (name value)
- (if (eq? name (car path))
- (if (lambda? value)
- (find-lambda value (cdr path))
- (error "Internal definition not a procedure" path))
- (loop (cdr elements))))))
- (else
- (loop (cdr elements)))))
-
- (if (null? path)
- lambda
- (lambda-components* lambda
- (lambda (name required optional rest body)
- (loop (sequence-actions body))))))
-
- (if (null? path)
- (procedure-lambda procedure)
- (find-lambda (procedure-lambda procedure) (car path))))
-
-;; The LIST-COPY will prevent any mutation problems.
-(define ((wrap-advice-extractor extractor) procedure . path)
- (list-copy (extractor (find-internal-lambda procedure path))))
-
-(define advice (wrap-advice-extractor primitive-advice))
-(define entry-advice (wrap-advice-extractor primitive-entry-advice))
-(define exit-advice (wrap-advice-extractor primitive-exit-advice))
-
-(define ((wrap-general-advisor advisor) procedure advice . path)
- (advisor (find-internal-lambda procedure path) advice)
- *the-non-printing-object*)
-
-(define advise-entry (wrap-general-advisor primitive-advise-entry))
-(define advise-exit (wrap-general-advisor primitive-advise-exit))
-\f
-(define (((wrap-unadvisor map-over-population) unadvisor) . procedure&path)
- (if (null? procedure&path)
- (map-over-population unadvisor)
- (unadvisor (find-internal-lambda (car procedure&path)
- (cdr procedure&path))))
- *the-non-printing-object*)
-
-(define wrap-entry-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population entry-advice-population operation))))
-
-(define wrap-exit-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population exit-advice-population operation))))
-
-(define wrap-both-unadvisor
- (wrap-unadvisor
- (lambda (operation)
- (map-over-population entry-advice-population operation)
- (map-over-population exit-advice-population operation))))
-
-(define unadvise (wrap-both-unadvisor primitive-unadvise-entire-lambda))
-(define unadvise-entry (wrap-entry-unadvisor primitive-unadvise-entire-entry))
-(define unadvise-exit (wrap-exit-unadvisor primitive-unadvise-entire-exit))
-
-(define untrace (wrap-both-unadvisor primitive-untrace))
-(define untrace-entry (wrap-entry-unadvisor primitive-untrace-entry))
-(define untrace-exit (wrap-exit-unadvisor primitive-untrace-exit))
-
-(define unbreak (wrap-both-unadvisor primitive-unbreak))
-(define unbreak-entry (wrap-entry-unadvisor primitive-unbreak-entry))
-(define unbreak-exit (wrap-exit-unadvisor primitive-unbreak-exit))
-
-(define ((wrap-advisor advisor) procedure . path)
- (advisor (find-internal-lambda procedure path))
- *the-non-printing-object*)
-
-(define trace-entry (wrap-advisor primitive-trace-entry))
-(define trace-exit (wrap-advisor primitive-trace-exit))
-(define trace-both (wrap-advisor primitive-trace-both))
-
-(define break-entry (wrap-advisor primitive-break-entry))
-(define break-exit (wrap-advisor primitive-break-exit))
-(define break-both (wrap-advisor primitive-break-both))
-\f
-;;; end of ADVICE-PACKAGE.
-))
-
-;;;; Exports
-
-(define advice (access advice advice-package))
-(define entry-advice (access entry-advice advice-package))
-(define exit-advice (access exit-advice advice-package))
-
-(define advise-entry (access advise-entry advice-package))
-(define advise-exit (access advise-exit advice-package))
-
-(define unadvise (access unadvise advice-package))
-(define unadvise-entry (access unadvise-entry advice-package))
-(define unadvise-exit (access unadvise-exit advice-package))
-
-(define trace (access trace-both advice-package))
-(define trace-entry (access trace-entry advice-package))
-(define trace-exit (access trace-exit advice-package))
-(define trace-both (access trace-both advice-package))
-
-(define untrace (access untrace advice-package))
-(define untrace-entry (access untrace-entry advice-package))
-(define untrace-exit (access untrace-exit advice-package))
-
-(define break (access break-both advice-package))
-(define break-entry (access break-entry advice-package))
-(define break-exit (access break-exit advice-package))
-(define break-both (access break-both advice-package))
-
-(define unbreak (access unbreak advice-package))
-(define unbreak-entry (access unbreak-entry advice-package))
-(define unbreak-exit (access unbreak-exit advice-package))
-
-(define *args* (access *args* advice-package))
-(define *proc* (access *proc* advice-package))
-(define *result* (access *result* advice-package))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/bitstr.scm,v 13.41 1987/01/23 00:09:36 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Bit String Primitives
-
-(declare (usual-integrations))
-\f
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name
- ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- bit-string-allocate make-bit-string bit-string?
- bit-string-length bit-string-ref bit-string-clear! bit-string-set!
- bit-string-zero? bit-string=?
- bit-string-fill! bit-string-move! bit-string-movec!
- bit-string-or! bit-string-and! bit-string-andc!
- bit-substring-move-right!
- bit-string->unsigned-integer unsigned-integer->bit-string
- read-bits! write-bits!)))
-
-(define (bit-string-append x y)
- (let ((x-length (bit-string-length x))
- (y-length (bit-string-length y)))
- (let ((result (bit-string-allocate (+ x-length y-length))))
- (bit-substring-move-right! x 0 x-length result 0)
- (bit-substring-move-right! y 0 y-length result x-length)
- result)))
-
-(define (bit-substring bit-string start end)
- (let ((result (bit-string-allocate (- end start))))
- (bit-substring-move-right! bit-string start end result 0)
- result))
-
-(define (signed-integer->bit-string nbits number)
- (unsigned-integer->bit-string nbits
- (if (negative? number)
- (+ number (expt 2 nbits))
- number)))
-
-(define (bit-string->signed-integer bit-string)
- (let ((unsigned-result (bit-string->unsigned-integer bit-string))
- (nbits (bit-string-length bit-string)))
- (if (bit-string-ref bit-string (-1+ nbits)) ;Sign bit.
- (- unsigned-result (expt 2 nbits))
- unsigned-result)))
- unsigned-result)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/boot.scm,v 13.43 1987/04/17 00:58:33 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Boot Utilities
-
-(declare (usual-integrations))
-
-;;; The utilities in this file are the first thing loaded into the
-;;; world after the type tables. They can't depend on anything else
-;;; except those tables.
-\f
-;;;; Primitive Operators
-
-(let-syntax ((define-global-primitives
- (macro names
- `(BEGIN
- ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))))
- (define-global-primitives
- SCODE-EVAL FORCE WITH-THREADED-CONTINUATION
- SET-INTERRUPT-ENABLES! WITH-INTERRUPTS-REDUCED
- WITH-INTERRUPT-MASK
- GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
- PRIMITIVE-PROCEDURE-ARITY NOT FALSE?
- UNSNAP-LINKS!
-
- ;; Environment
- LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT
- LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE?
-
- ;; Pointers
- EQ?
- PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT
- PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM
- OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS
-
- ;; List Operations
- ;; (these appear here for the time being because the compiler
- ;; couldn't handle the `in-package' required to put them in
- ;; `list.scm'. They should be moved back when that is fixed.
- CONS PAIR? NULL? LENGTH CAR CDR SET-CAR! SET-CDR!
- GENERAL-CAR-CDR MEMQ ASSQ
-
- ;; System Compound Datatypes
- MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS!
-
- SYSTEM-PAIR-CONS SYSTEM-PAIR?
- SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR!
- SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR!
-
- SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0!
- SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1!
- SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2!
-
- SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR?
- SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET!
- )
-;;; end of DEFINE-GLOBAL-PRIMITIVES scope.
-)
-\f
-;;;; Potpourri
-
-(define *the-non-printing-object* '(*THE-NON-PRINTING-OBJECT*))
-(define (identity-procedure x) x)
-(define false #F)
-(define true #T)
-
-(define (null-procedure . args) '())
-(define (false-procedure . args) #F)
-(define (true-procedure . args) #T)
-
-(define (without-interrupts thunk)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
- (thunk))))
-
-(define apply
- (let ((primitive (make-primitive-procedure 'APPLY)))
- (named-lambda (apply f . args)
- (primitive f
- (if (null? args)
- '()
- (let loop
- ((first-element (car args))
- (rest-elements (cdr args)))
- (if (null? rest-elements)
- first-element
- (cons first-element
- (loop (car rest-elements)
- (cdr rest-elements))))))))))
-
-(define system-hunk3-cons
- (let ((hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
- (named-lambda (system-hunk3-cons type cxr0 cxr1 cxr2)
- (primitive-set-type type (hunk3-cons cxr0 cxr1 cxr2)))))
-
-(define (symbol-hash symbol)
- (string-hash (symbol->string symbol)))
-
-(define (symbol-append . symbols)
- (string->symbol (apply string-append (map symbol->string symbols))))
-
-(define (boolean? object)
- (or (eq? object #F)
- (eq? object #T)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/char.scm,v 13.41 1987/01/23 00:09:52 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; New Character Abstraction
-
-(declare (usual-integrations))
-\f
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- make-char char-code char-bits
- char->integer integer->char char->ascii
- char-ascii? ascii->char
- char-upcase char-downcase)))
-
-(define char-code-limit #x80)
-(define char-bits-limit #x20)
-(define char-integer-limit (* char-code-limit char-bits-limit))
-
-(define (chars->ascii chars)
- (map char->ascii chars))
-
-(define (code->char code)
- (make-char code 0))
-
-(define (char=? x y)
- (= (char->integer x) (char->integer y)))
-
-(define (char<? x y)
- (< (char->integer x) (char->integer y)))
-
-(define (char<=? x y)
- (<= (char->integer x) (char->integer y)))
-
-(define (char>? x y)
- (> (char->integer x) (char->integer y)))
-
-(define (char>=? x y)
- (>= (char->integer x) (char->integer y)))
-
-(define (char-ci->integer char)
- (char->integer (char-upcase char)))
-
-(define (char-ci=? x y)
- (= (char-ci->integer x) (char-ci->integer y)))
-
-(define (char-ci<? x y)
- (< (char-ci->integer x) (char-ci->integer y)))
-
-(define (char-ci<=? x y)
- (<= (char-ci->integer x) (char-ci->integer y)))
-
-(define (char-ci>? x y)
- (> (char-ci->integer x) (char-ci->integer y)))
-
-(define (char-ci>=? x y)
- (>= (char-ci->integer x) (char-ci->integer y)))
-\f
-(define char?)
-(define digit->char)
-(define char->digit)
-(define name->char)
-(define char->name)
-(let ()
-
-(define char-type
- (microcode-type 'CHARACTER))
-
-(define 0-code (char-code (ascii->char #x30)))
-(define upper-a-code (char-code (ascii->char #x41)))
-(define lower-a-code (char-code (ascii->char #x61)))
-(define space-char (ascii->char #x20))
-(define hyphen-char (ascii->char #x2D))
-(define backslash-char (ascii->char #x5C))
-
-(define named-codes
- `(("Backspace" . #x08)
- ("Tab" . #x09)
- ("Linefeed" . #x0A)
- ("VT" . #x0B)
- ("Page" . #x0C)
- ("Return" . #x0D)
- ("Call" . #x1A)
- ("Altmode" . #x1B)
- ("Backnext" . #x1F)
- ("Space" . #x20)
- ("Rubout" . #x7F)
- ))
-
-(define named-bits
- `(("C" . #o01)
- ("Control" . #o01)
- ("M" . #o02)
- ("Meta" . #o02)
- ("S" . #o04)
- ("Super" . #o04)
- ("H" . #o10)
- ("Hyper" . #o10)
- ("T" . #o20)
- ("Top" . #o20)
- ))
-\f
-(define (-map-> alist string start end)
- (define (loop entries)
- (and (not (null? entries))
- (let ((key (caar entries)))
- (if (substring-ci=? string start end
- key 0 (string-length key))
- (cdar entries)
- (loop (cdr entries))))))
- (loop alist))
-
-(define (<-map- alist n)
- (define (loop entries)
- (and (not (null? entries))
- (if (= n (cdar entries))
- (caar entries)
- (loop (cdr entries)))))
- (loop alist))
-
-(set! char?
-(named-lambda (char? object)
- (primitive-type? char-type object)))
-
-(set! digit->char
-(named-lambda (digit->char digit #!optional radix)
- (cond ((unassigned? radix) (set! radix 10))
- ((not (and (<= 2 radix) (<= radix 36)))
- (error "DIGIT->CHAR: Bad radix" radix)))
- (and (<= 0 digit) (< digit radix)
- (code->char (if (< digit 10)
- (+ digit 0-code)
- (+ (- digit 10) upper-a-code))))))
-
-(set! char->digit
-(named-lambda (char->digit char #!optional radix)
- (cond ((unassigned? radix) (set! radix 10))
- ((not (and (<= 2 radix) (<= radix 36)))
- (error "CHAR->DIGIT: Bad radix" radix)))
- (and (zero? (char-bits char))
- (let ((code (char-code char)))
- (define (try base-digit base-code)
- (let ((n (+ base-digit (- code base-code))))
- (and (<= base-digit n)
- (< n radix)
- n)))
- (or (try 0 0-code)
- (try 10 upper-a-code)
- (try 10 lower-a-code))))))
-\f
-(set! name->char
-(named-lambda (name->char string)
- (let ((end (string-length string))
- (bits '()))
- (define (loop start)
- (let ((left (- end start)))
- (cond ((zero? left)
- (error "Missing character name"))
- ((= left 1)
- (let ((char (string-ref string start)))
- (if (char-graphic? char)
- (char-code char)
- (error "Non-graphic character" char))))
- (else
- (let ((hyphen (substring-find-next-char string start end
- hyphen-char)))
- (if (not hyphen)
- (name->code string start end)
- (let ((bit (-map-> named-bits string start hyphen)))
- (if (not bit)
- (name->code string start end)
- (begin (if (not (memv bit bits))
- (set! bits (cons bit bits)))
- (loop (1+ hyphen)))))))))))
- (let ((code (loop 0)))
- (make-char code (apply + bits))))))
-
-(define (name->code string start end)
- (if (substring-ci=? string start end "Newline" 0 7)
- (char-code char:newline)
- (or (-map-> named-codes string start end)
- (error "Unknown character name" (substring string start end)))))
-\f
-(set! char->name
-(named-lambda (char->name char #!optional slashify?)
- (if (unassigned? slashify?) (set! slashify? false))
- (define (loop weight bits)
- (if (zero? bits)
- (let ((code (char-code char)))
- (let ((base-char (code->char code)))
- (cond ((<-map- named-codes code))
- ((and slashify?
- (not (zero? (char-bits char)))
- (or (char=? base-char backslash-char)
- (char-set-member? (access atom-delimiters
- parser-package)
- base-char)))
- (string-append "\\" (char->string base-char)))
- ((char-graphic? base-char)
- (char->string base-char))
- (else
- (string-append "<code "
- (write-to-string code)
- ">")))))
- (let ((qr (integer-divide bits 2)))
- (let ((rest (loop (* weight 2) (integer-divide-quotient qr))))
- (if (zero? (integer-divide-remainder qr))
- rest
- (string-append (or (<-map- named-bits weight)
- (string-append "<bit "
- (write-to-string weight)
- ">"))
- "-"
- rest))))))
- (loop 1 (char-bits char))))
-
-)
-\f
-;;;; Character Sets
-
-(define (char-set? object)
- (and (string? object) (= (string-length object) 256)))
-
-(define (char-set . chars)
- (let ((char-set (string-allocate 256)))
- (vector-8b-fill! char-set 0 256 0)
- (for-each (lambda (char) (vector-8b-set! char-set (char->ascii char) 1))
- chars)
- char-set))
-
-(define (predicate->char-set predicate)
- (let ((char-set (string-allocate 256)))
- (define (loop code)
- (if (< code 256)
- (begin (vector-8b-set! char-set code
- (if (predicate (ascii->char code)) 1 0))
- (loop (1+ code)))))
- (loop 0)
- char-set))
-
-(define (char-set-members char-set)
- (define (loop code)
- (cond ((>= code 256) '())
- ((zero? (vector-8b-ref char-set code)) (loop (1+ code)))
- (else (cons (ascii->char code) (loop (1+ code))))))
- (loop 0))
-
-(define (char-set-member? char-set char)
- (let ((ascii (char-ascii? char)))
- (and ascii (not (zero? (vector-8b-ref char-set ascii))))))
-
-(define (char-set-invert char-set)
- (predicate->char-set
- (lambda (char) (not (char-set-member? char-set char)))))
-
-(define (char-set-union char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (or (char-set-member? char-set-1 char)
- (char-set-member? char-set-2 char)))))
-
-(define (char-set-intersection char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (and (char-set-member? char-set-1 char)
- (char-set-member? char-set-2 char)))))
-
-(define (char-set-difference char-set-1 char-set-2)
- (predicate->char-set
- (lambda (char)
- (and (char-set-member? char-set-1 char)
- (not (char-set-member? char-set-2 char))))))
-\f
-;;;; System Character Sets
-
-(define char-set:upper-case
- (predicate->char-set
- (let ((lower (ascii->char #x41))
- (upper (ascii->char #x5A)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:lower-case
- (predicate->char-set
- (let ((lower (ascii->char #x61))
- (upper (ascii->char #x7A)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:numeric
- (predicate->char-set
- (let ((lower (ascii->char #x30))
- (upper (ascii->char #x39)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:alphabetic
- (char-set-union char-set:upper-case char-set:lower-case))
-
-(define char-set:alphanumeric
- (char-set-union char-set:alphabetic char-set:numeric))
-
-(define char-set:graphic
- (predicate->char-set
- (let ((lower (ascii->char #x20))
- (upper (ascii->char #x7E)))
- (lambda (char)
- (and (char<=? lower char)
- (char<=? char upper))))))
-
-(define char-set:standard
- (char-set-union char-set:graphic (char-set (ascii->char #x0D))))
-
-(define char-set:whitespace
- (char-set (ascii->char #x09) ;Tab
- (ascii->char #x0A) ;Linefeed
- (ascii->char #x0C) ;Page
- (ascii->char #x0D) ;Return
- (ascii->char #x20) ;Space
- ))
-
-(define char-set:not-whitespace
- (char-set-invert char-set:whitespace))
-\f
-(define ((char-set-predicate char-set) char)
- (char-set-member? char-set char))
-
-(define char-upper-case? (char-set-predicate char-set:upper-case))
-(define char-lower-case? (char-set-predicate char-set:lower-case))
-(define char-numeric? (char-set-predicate char-set:numeric))
-(define char-alphabetic? (char-set-predicate char-set:alphabetic))
-(define char-alphanumeric? (char-set-predicate char-set:alphanumeric))
-(define char-graphic? (char-set-predicate char-set:graphic))
-(define char-standard? (char-set-predicate char-set:standard))
-(define char-whitespace? (char-set-predicate char-set:whitespace))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/datime.scm,v 13.41 1987/01/23 00:11:08 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Date and Time Routines
-
-(declare (usual-integrations))
-\f
-;;;; Date and Time
-
-(define date
- (let ((year (make-primitive-procedure 'CURRENT-YEAR))
- (month (make-primitive-procedure 'CURRENT-MONTH))
- (day (make-primitive-procedure 'CURRENT-DAY)))
- (named-lambda (date #!optional receiver)
- ((if (unassigned? receiver) list receiver)
- (year) (month) (day)))))
-
-(define time
- (let ((hour (make-primitive-procedure 'CURRENT-HOUR))
- (minute (make-primitive-procedure 'CURRENT-MINUTE))
- (second (make-primitive-procedure 'CURRENT-SECOND)))
- (named-lambda (time #!optional receiver)
- ((if (unassigned? receiver) list receiver)
- (hour) (minute) (second)))))
-\f
-(define date->string)
-(define time->string)
-(let ()
-
-(set! date->string
-(named-lambda (date->string year month day)
- (if year
- (string-append
- (vector-ref days-of-the-week
- (let ((qr (integer-divide year 4)))
- (remainder (+ (* year 365)
- (if (and (zero? (integer-divide-remainder qr))
- (<= month 2))
- (integer-divide-quotient qr)
- (1+ (integer-divide-quotient qr)))
- (vector-ref days-through-month (-1+ month))
- day
- 6)
- 7)))
- " "
- (vector-ref months-of-the-year (-1+ month))
- " "
- (write-to-string day)
- ", 19"
- (write-to-string year))
- "Date primitives not installed")))
-
-(define months-of-the-year
- #("January" "February" "March" "April" "May" "June" "July"
- "August" "September" "October" "November" "December"))
-
-(define days-of-the-week
- #("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
-
-(define days-through-month
- (let ()
- (define (month-loop months value)
- (if (null? months)
- '()
- (cons value
- (month-loop (cdr months) (+ value (car months))))))
- (list->vector (month-loop '(31 28 31 30 31 30 31 31 30 31 30 31) 0))))
-
-(set! time->string
-(named-lambda (time->string hour minute second)
- (if hour
- (string-append (write-to-string
- (cond ((zero? hour) 12)
- ((< hour 13) hour)
- (else (- hour 12))))
- (if (< minute 10) ":0" ":")
- (write-to-string minute)
- (if (< second 10) ":0" ":")
- (write-to-string second)
- " "
- (if (< hour 12) "AM" "PM"))
- "Time primitives not installed")))
-
-)
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 13.42 1987/03/17 18:49:00 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Debugger
-
-(in-package debugger-package
-(declare (usual-integrations))
-\f
-(define debug-package
- (make-environment
-
-(define current-continuation)
-(define previous-continuations)
-(define current-reduction-number)
-(define current-number-of-reductions)
-(define current-reduction)
-(define current-environment)
-
-(define command-set
- (make-command-set 'DEBUG-COMMANDS))
-
-(define reduction-wrap-around-tag
- 'WRAP-AROUND)
-
-(define print-user-friendly-name
- (access print-user-friendly-name env-package))
-
-(define print-expression
- pp)
-
-(define student-walk?
- false)
-
-(define print-return-values?
- false)
-
-(define (define-debug-command letter function help-text)
- (define-letter-command command-set letter function help-text))
-
-;;; Basic Commands
-
-(define-debug-command #\? (standard-help-command command-set)
- "Help, list command letters")
-
-(define-debug-command #\Q standard-exit-command "Quit (exit DEBUG)")
-
-(define (debug #!optional the-continuation)
- (fluid-let ((current-continuation)
- (previous-continuations '())
- (current-reduction-number)
- (current-number-of-reductions)
- (current-reduction false)
- (current-environment '()))
- (debug-abstract-continuation
- (cond ((unassigned? the-continuation) (rep-continuation))
- ((raw-continuation? the-continuation); Must precede next test!
- (raw-continuation->continuation the-continuation))
- ((continuation? the-continuation) the-continuation)
- (else (error "DEBUG: Not a continuation" the-continuation))))))
-\f
-(define (debug-abstract-continuation continuation)
- (set-current-continuation! continuation initial-reduction-number)
- (letter-commands command-set
- (lambda ()
- (print-current-expression)
- ((standard-rep-message "Debugger")))
- (standard-rep-prompt "Debug-->")))
-
-(define (undefined-environment? environment)
- (or (continuation-undefined-environment? environment)
- (eq? environment system-global-environment)
- (and (environment? environment)
- ((access system-external-environment? environment-package)
- environment))))
-
-(define (print-undefined-environment)
- (format "~%Undefined environment at this subproblem/reduction level"))
-
-(define (with-rep-alternative env receiver)
- (if (undefined-environment? env)
- (begin
- (print-undefined-environment)
- (format "~%Using the read-eval-print environment instead!")
- (receiver (rep-environment)))
- (receiver env)))
-
-(define (if-valid-environment env receiver)
- (if (undefined-environment? env)
- (print-undefined-environment)
- (receiver env)))
-
-(define (current-expression)
- (if current-reduction
- (reduction-expression current-reduction)
- (let ((exp (continuation-expression current-continuation)))
- (if (or (not (continuation-undefined-expression? exp))
- (null? (continuation-annotation current-continuation)))
- exp
- (cons 'UNDEFINED-EXPRESSION
- (continuation-annotation current-continuation))))))
-\f
-;;;; Random display commands
-
-(define (pretty-print-current-expression)
- (print-expression (current-expression)))
-
-(define-debug-command #\L pretty-print-current-expression
- "(list expression) Pretty-print the current expression")
-
-(define (pretty-print-reduction-function)
- (if-valid-environment (if current-reduction
- (reduction-environment current-reduction)
- current-environment)
- (lambda (env) (pp (environment-procedure env)))))
-
-(define-debug-command #\P pretty-print-reduction-function
- "Pretty print current procedure")
-
-(define (print-current-expression)
- (define (print-current-reduction)
- (format "~2xReduction Number:~x~o~%Expression:" current-reduction-number)
- (print-expression (reduction-expression current-reduction)))
-
- (define (print-application-information env)
- (define (do-it return?)
- (if return? (format "~%within ") (format "within "))
- (print-user-friendly-name env)
- (if return?
- (format "~%applied to ~@68o" (environment-arguments env))
- (format " applied to ~@68o" (environment-arguments env))))
-
- (let ((output (with-output-to-string (lambda () (do-it false)))))
- (if (< (string-length output)
- (access printer-width implementation-dependencies))
- (format "~%~s" output)
- (do-it true))))
-
- (if (null-continuation? current-continuation)
- (format "~%Null continuation")
- (begin
- (format "~%Subproblem Level: ~o" (length previous-continuations))
- (if current-reduction
- (print-current-reduction)
- (begin
- (format "~%Possibly Incomplete Expression:")
- (print-expression (continuation-expression current-continuation))))
- (if-valid-environment current-environment
- print-application-information))))
-
-(define-debug-command #\S print-current-expression
- "Print the current subproblem/reduction")
-\f
-(define (reductions-command)
- (if (null-continuation? current-continuation)
- (format "~%Null continuation")
- (let loop ((r (continuation-reductions current-continuation)))
- (cond ((pair? r)
- (print-expression (reduction-expression (car r)))
- (loop (cdr r)))
- ((wrap-around-in-reductions? r)
- (format "~%Wrap Around in the reductions at this level."))
- (else 'done)))))
-
-(define-debug-command #\R reductions-command
- "Print the reductions of the current subproblem level")
-\f
-;;;; Short history display
-
-(define (summarize-history-command)
- (define (print-continuations cont level)
- (define (print-reductions reductions show-all?)
- (define (print-reduction red number)
- (terse-print-expression level
- (reduction-expression red)
- (reduction-environment red)))
-
- (let loop ((reductions reductions) (number 0))
- (if (pair? reductions)
- (begin
- (print-reduction (car reductions) number)
- (if show-all? (loop (cdr reductions) (1+ number)))))))
-
- (if (null-continuation? cont)
- *the-non-printing-object*
- (begin
- (let ((reductions (continuation-reductions cont)))
- (if (not (pair? reductions))
- (terse-print-expression level
- (continuation-expression cont)
- (continuation-environment cont))
- (print-reductions reductions (= level 0))))
- (print-continuations (continuation-next-continuation cont)
- (1+ level)))))
-
- (let ((top-continuation (if (null? previous-continuations)
- current-continuation
- (car (last-pair previous-continuations)))))
- (if (null-continuation? top-continuation)
- (format "~%No history available")
- (begin
- (format "~%Sub Prb. Procedure Name Expression~%")
- (print-continuations top-continuation 0)))))
-
-(define (terse-print-expression level expression environment)
- (format "~%~@3o~:20o~4x~@:52c"
- level
- ;; procedure name
- (if (or (undefined-environment? environment)
- (special-name? (environment-name environment)))
- *the-non-printing-object*
- (environment-name environment))
- expression))
-
-(define-debug-command #\H summarize-history-command
- "Prints a summary of the entire history")
-\f
-;;;; Motion to earlier expressions
-
-(define (earlier-reduction)
- (define (up! message)
- (format "~%~s~%Going to the previous (earlier) continuation!" message)
- (earlier-continuation-command))
-
- (cond ((and student-walk?
- (> (length previous-continuations) 0)
- (= current-reduction-number 0))
- (earlier-continuation-command))
- ((< current-reduction-number (-1+ current-number-of-reductions))
- (set-current-reduction! (1+ current-reduction-number))
- (print-current-expression))
- ((wrap-around-in-reductions?
- (continuation-reductions current-continuation))
- (up! "Wrap around in reductions at this level!"))
- (else (up! "No more reductions at this level!"))))
-
-(define-debug-command #\B earlier-reduction "Earlier reduction (Back in time)")
-
-(define (earlier-subproblem)
- (let ((new (continuation-next-continuation current-continuation)))
- (set! previous-continuations
- (cons current-continuation previous-continuations))
- (set-current-continuation! new normal-reduction-number)))
-
-(define (earlier-continuation-command)
- (if (not (null-continuation? (continuation-next-continuation
- current-continuation)))
- (earlier-subproblem)
- (format "~%There are only ~o subproblem levels"
- (length previous-continuations)))
- (print-current-expression))
-
-(define-debug-command #\U earlier-continuation-command
- "Move (Up) to the previous (earlier) continuation")
-\f
-;;;; Motion to later expressions
-
-(define (later-reduction)
- (cond ((> current-reduction-number 0)
- (set-current-reduction! (-1+ current-reduction-number))
- (print-current-expression))
- ((or (not student-walk?)
- (= (length previous-continuations) 1))
- (later-continuation-TO-LAST-REDUCTION))
- (else (later-continuation))))
-
-(define-debug-command #\F later-reduction "Later reduction (Forward in time)")
-
-(define (later-continuation)
- (if (null? previous-continuations)
- (format "~%Already at lowest subproblem level")
- (begin (later-subproblem) (print-current-expression))))
-
-(define (later-continuation-TO-LAST-REDUCTION)
- (define (later-subproblem-TO-LAST-REDUCTION)
- (set-current-continuation!
- (car (set! previous-continuations (cdr previous-continuations)))
- last-reduction-number))
-
- (if (null? previous-continuations)
- (format "~%Already at lowest subproblem level")
- (begin (later-subproblem-TO-LAST-REDUCTION)
- (print-current-expression))))
-
-(define (later-subproblem)
- (set-current-continuation!
- (car (set! previous-continuations (cdr previous-continuations)))
- normal-reduction-number))
-
-(define (later-continuation-command)
- (if (null? previous-continuations)
- (format "~%Already at oldest continuation")
- (begin (later-subproblem) (print-current-expression))))
-
-(define-debug-command #\D later-continuation-command
- "Move (Down) to the next (later) continuation")
-\f
-;;;; General motion command
-
-(define (goto-command)
- (define (get-reduction-number)
- (format "~%Reduction Number (0 through ~o inclusive): "
- (-1+ current-number-of-reductions))
- (let ((red (read)))
- (cond ((not (number? red))
- (beep)
- (format "~%Reduction number must be numeric!")
- (get-reduction-number))
- ((not (and (>= red 0)
- (< red current-number-of-reductions)))
- (format "~%Reduction number out of range.!")
- (get-reduction-number))
- (else (set-current-reduction! red)))))
-
- (define (choose-reduction)
- (cond ((> current-number-of-reductions 1) (get-reduction-number))
- ((= current-number-of-reductions 1)
- (format "~%There is only one reduction for this subproblem")
- (set-current-reduction! 1))
- (else (format "~%There are no reductions for this subproblem."))))
-
- (define (get-subproblem-number)
- (format "~%Subproblem number: ")
- (let ((len (length previous-continuations)) (sub (read)))
- (cond ((not (number? sub))
- (beep)
- (format "~%Subproblem level must be numeric!")
- (get-subproblem-number))
- ((< sub len) (repeat later-subproblem (- len sub))
- (choose-reduction))
- (else
- (let loop ((len len))
- (cond ((= sub len) (choose-reduction))
- ((null-continuation?
- (continuation-next-continuation current-continuation))
- (format "~%There is no such subproblem.")
- (format "~%Now at subproblem number: ~o"
- (length previous-continuations))
- (choose-reduction))
- (else (earlier-subproblem) (loop (1+ len)))))))))
-
- (get-subproblem-number)
- (print-current-expression))
-
-(define-debug-command #\G goto-command
- "Go to a particular Subproblem/Reduction level")
-\f
-;;;; Evaluation and frame display commands
-
-(define (enter-read-eval-print-loop)
- (with-rep-alternative
- current-environment
- (lambda (env)
- (read-eval-print env
- "You are now in the desired environment"
- "Eval-in-env-->"))))
-
-(define-debug-command #\E enter-read-eval-print-loop
- "Enter a read-eval-print loop in the current environment")
-
-(define (eval-in-current-environment)
- (with-rep-alternative current-environment
- (lambda (env)
- (environment-warning-hook env)
- (format "~%Eval--> ")
- (eval (read) env))))
-
-(define-debug-command #\V eval-in-current-environment
- "Evaluate expression in current environment")
-
-(define show-current-frame
- (let ((show-frame (access show-frame env-package)))
- (named-lambda (show-current-frame)
- (if-valid-environment current-environment
- (lambda (env) (show-frame env -1))))))
-
-(define-debug-command #\C show-current-frame
- "Show Bindings of identifiers in the current environment")
-
-(define (enter-where-command)
- (with-rep-alternative current-environment where))
-
-(define-debug-command #\W enter-where-command
- "Enter WHERE on the current environment")
-
-(define (error-info-command)
- (format "~% Message: ~s~%Irritant: ~o" (error-message) (error-irritant)))
-
-(define-debug-command #\I error-info-command "Redisplay the error message")
-\f
-;;;; Advanced hacking commands
-
-(define (return-command) ;command Z
- (define (confirm)
- (format "~%Confirm: [Y or N] ")
- (let ((ans (read)))
- (cond ((eq? ans 'Y) true)
- ((eq? ans 'N) false)
- (else (confirm)))))
-
- (define (return-read)
- (let ((exp (read)))
- (if (eq? exp '$)
- (unsyntax (current-expression))
- exp)))
-
- (define (do-it environment next)
- (environment-warning-hook environment)
- (format "~%Expression to EVALUATE and CONTINUE with ($ to retry): ")
- (if print-return-values?
- (let ((eval-exp (eval (return-read) environment)))
- (format "~%That evaluates to:~%~o" eval-exp)
- (if (confirm) (next eval-exp)))
- (next (eval (return-read) environment))))
-
- (let ((next (continuation-next-continuation current-continuation)))
- (if (null-continuation? next)
- (begin (beep) (format "~%Can't continue!!!"))
- (with-rep-alternative current-environment
- (lambda (env) (do-it env next))))))
-
-(define-debug-command #\Z return-command
- "Return (continue with) an expression after evaluating it")
-
-(define user-debug-environment (make-environment))
-
-(define (internal-command)
- (read-eval-print user-debug-environment
- "You are now in the debugger environment"
- "Debugger-->"))
-
-(define-debug-command #\X internal-command
- "Create a read eval print loop in the debugger environment")
-\f
-;;;; Reduction and continuation motion low-level
-
-(define reduction-expression car)
-(define reduction-environment cadr)
-
-(define (last-reduction-number)
- (-1+ current-number-of-reductions))
-
-(define (normal-reduction-number)
- (min (-1+ current-number-of-reductions) 0))
-
-(define (initial-reduction-number)
- (let ((environment (continuation-environment current-continuation)))
- (if (and (environment? environment)
- (let ((procedure (environment-procedure environment)))
- (or (eq? procedure error-procedure)
- (eq? procedure breakpoint-procedure))))
- 1
- 0)))
-
-(define (set-current-continuation! continuation hook)
- (set! current-continuation continuation)
- (set! current-number-of-reductions
- (if (null-continuation? continuation)
- 0
- (dotted-list-length
- (continuation-reductions current-continuation))))
- (set-current-reduction! (hook)))
-
-(define (set-current-reduction! number)
- (set! current-reduction-number number)
- (if (and (not (= current-number-of-reductions 0)) (>= number 0))
- (set! current-reduction
- (list-ref (continuation-reductions current-continuation) number))
- (set! current-reduction false))
- (set! current-environment
- (if current-reduction
- (reduction-environment current-reduction)
- (continuation-environment current-continuation))))
-
-(define (repeat f n)
- (if (> n 0)
- (begin (f)
- (repeat f (-1+ n)))))
-
-(define (dotted-list-length l)
- (let count ((n 0) (L L))
- (if (pair? l)
- (count (1+ n) (CDR L))
- n)))
-
-(define (wrap-around-in-reductions? reductions)
- (eq? (list-tail reductions (dotted-list-length reductions))
- reduction-wrap-around-tag))
-\f
-;;; end DEBUG-PACKAGE.
-))
-
-;;; end IN-PACKAGE DEBUGGER-PACKAGE.
-)
-
-(define debug
- (access debug debug-package debugger-package))
-
-(define special-name?
- (let ((the-special-names
- (list lambda-tag:unnamed
- (access internal-lambda-tag lambda-package)
- (access internal-lexpr-tag lambda-package)
- lambda-tag:let
- lambda-tag:shallow-fluid-let
- lambda-tag:deep-fluid-let
- lambda-tag:common-lisp-fluid-let
- lambda-tag:make-environment)))
- (named-lambda (special-name? symbol)
- (memq symbol the-special-names))))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 13.42 1987/03/07 17:36:00 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; GNU Emacs/Scheme Modeline Interface
-
-(declare (usual-integrations))
-\f
-(define emacs-interface-package
- (make-environment
-
-(define (transmit-signal type)
- (write-char #\Altmode console-output-port)
- (write-char type console-output-port))
-
-(define (transmit-signal-without-gc type)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-mask)
- (transmit-signal type))))
-
-(define (emacs-read-start)
- (transmit-signal-without-gc #\s))
-
-(define (emacs-read-finish)
- (transmit-signal-without-gc #\f))
-
-(define (emacs-start-gc)
- (transmit-signal #\b))
-
-(define (emacs-finish-gc state)
- (transmit-signal #\e))
-
-(define (transmit-signal-with-argument type string)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-mask)
- (transmit-signal type)
- (write-string string console-output-port)
- (write-char #\Altmode console-output-port))))
-
-(define (emacs-rep-message string)
- (transmit-signal-with-argument #\m string))
-
-(define (emacs-rep-prompt level string)
- (transmit-signal-with-argument #\p
- (string-append (object->string level)
- " "
- string)))
-
-(define (emacs-rep-value object)
- (transmit-signal-with-argument #\v (object->string object)))
-
-(define (object->string object)
- (with-output-to-string
- (lambda ()
- (write object))))
-\f
-(define (emacs-read-char-immediate)
- (define (loop)
- (let ((char (primitive-read-char-immediate)))
- (if (char=? char char:newline)
- (loop)
- (begin (emacs-read-finish)
- char))))
- (emacs-read-start)
- (if (not (primitive-read-char-ready? 0))
- (transmit-signal-without-gc #\c))
- (loop))
-
-(define primitive-read-char-ready?
- (make-primitive-procedure 'TTY-READ-CHAR-READY?))
-
-(define primitive-read-char-immediate
- (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
-
-(define paranoid-error-hook?
- false)
-
-(define (emacs-error-hook)
- (transmit-signal-without-gc #\z)
- (beep)
- (if paranoid-error-hook?
- (begin
- (transmit-signal-with-argument #\P
-"Error! Type ctl-E to enter error loop, anything else to return to top level.")
- (if (not (char-ci=? (emacs-read-char-immediate) #\C-E))
- (abort-to-previous-driver "Quit!")))))
-\f
-(define normal-start-gc (access gc-start-hook gc-statistics-package))
-(define normal-finish-gc (access gc-finish-hook gc-statistics-package))
-(define normal-rep-message rep-message-hook)
-(define normal-rep-prompt rep-prompt-hook)
-(define normal-rep-value rep-value-hook)
-(define normal-read-start (access read-start-hook console-input-port))
-(define normal-read-finish (access read-finish-hook console-input-port))
-(define normal-read-char-immediate
- (access tty-read-char-immediate console-input-port))
-(define normal-error-hook (access *error-decision-hook* error-system))
-
-(define (install-emacs-hooks!)
- (set! (access gc-start-hook gc-statistics-package) emacs-start-gc)
- (set! (access gc-finish-hook gc-statistics-package) emacs-finish-gc)
- (set! rep-message-hook emacs-rep-message)
- (set! rep-prompt-hook emacs-rep-prompt)
- (set! rep-value-hook emacs-rep-value)
- (set! (access read-start-hook console-input-port) emacs-read-start)
- (set! (access read-finish-hook console-input-port) emacs-read-finish)
- (set! (access tty-read-char-immediate console-input-port)
- emacs-read-char-immediate)
- (set! (access *error-decision-hook* error-system) emacs-error-hook))
-
-(define (install-normal-hooks!)
- (set! (access gc-start-hook gc-statistics-package) normal-start-gc)
- (set! (access gc-finish-hook gc-statistics-package) normal-finish-gc)
- (set! rep-message-hook normal-rep-message)
- (set! rep-prompt-hook normal-rep-prompt)
- (set! rep-value-hook normal-rep-value)
- (set! (access read-start-hook console-input-port) normal-read-start)
- (set! (access read-finish-hook console-input-port) normal-read-finish)
- (set! (access tty-read-char-immediate console-input-port)
- normal-read-char-immediate)
- (set! (access *error-decision-hook* error-system) normal-error-hook))
-
-(define under-emacs?
- (make-primitive-procedure 'UNDER-EMACS?))
-
-(define (install!)
- ((if (under-emacs?)
- install-emacs-hooks!
- install-normal-hooks!)))
-
-(add-event-receiver! event:after-restore install!)
-(install!)
-
-;;; end EMACS-INTERFACE-PACKAGE
-))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/equals.scm,v 13.42 1987/03/17 18:49:17 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Equality
-
-(declare (usual-integrations))
-\f
-(let-syntax ((type?
- ;; Use PRIMITIVE-TYPE? for everything because the
- ;; compiler can optimize it well.
- (macro (name object)
- `(PRIMITIVE-TYPE? ,(microcode-type name) ,object))))
-
-(define (eqv? x y)
- ;; EQV? is officially supposed to work on booleans, characters, and
- ;; numbers specially, but it turns out that EQ? does the right thing
- ;; for everything but numbers, so we take advantage of that.
- (if (eq? x y)
- true
- (and (primitive-type? (primitive-type x) y)
- (or (and (or (type? big-fixnum y)
- (type? big-flonum y))
- (= x y))
- (and (type? vector y)
- (zero? (vector-length x))
- (zero? (vector-length y)))))))
-
-(define (equal? x y)
- (if (eq? x y)
- true
- (and (primitive-type? (primitive-type x) y)
- (cond ((or (type? big-fixnum y)
- (type? big-flonum y))
- (= x y))
- ((type? list y)
- (and (equal? (car x) (car y))
- (equal? (cdr x) (cdr y))))
- ((type? vector y)
- (let ((size (vector-length x)))
- (define (loop index)
- (if (= index size)
- true
- (and (equal? (vector-ref x index)
- (vector-ref y index))
- (loop (1+ index)))))
- (and (= size (vector-length y))
- (loop 0))))
- ((type? cell y)
- (equal? (cell-contents x) (cell-contents y)))
- ((type? character-string y)
- (string=? x y))
- ((type? vector-1b y)
- (bit-string=? x y))
- (else false)))))
-
-)
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 13.46 1987/04/13 18:42:53 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Error System
-
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
-\f
-(define error-procedure
- (make-primitive-procedure 'ERROR-PROCEDURE))
-
-(define (error-from-compiled-code message . irritant-info)
- (error-procedure message
- (cond ((null? irritant-info) *the-non-printing-object*)
- ((null? (cdr irritant-info)) (car irritant-info))
- (else irritant-info))
- (rep-environment)))
-
-(define (error-message)
- (access error-message error-system))
-
-(define (error-irritant)
- (access error-irritant error-system))
-
-(define error-prompt
- "Error->")
-
-(define error-system
- (make-environment
-
-(define *error-code*)
-(define *error-hook*)
-(define *error-decision-hook* false)
-
-(define error-message
- "")
-
-(define error-irritant
- *the-non-printing-object*)
-\f
-;;;; REP Interface
-
-(define (error-procedure-handler message irritant environment)
- (with-proceed-point
- proceed-value-filter
- (lambda ()
- (fluid-let ((error-message message)
- (error-irritant irritant))
- (*error-hook* environment message irritant false)))))
-
-(define ((error-handler-wrapper handler) error-code interrupt-enables)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
- (fluid-let ((*error-code* error-code))
- (with-proceed-point
- proceed-value-filter
- (lambda ()
- (set-interrupt-enables! interrupt-enables)
- (handler (continuation-expression (rep-continuation)))))))))
-
-(define (wrapped-error-handler wrapper)
- (access handler (procedure-environment wrapper)))
-
-;;; (PROCEED) means retry error expression, (PROCEED value) means
-;;; return VALUE as the value of the error subproblem.
-
-(define (proceed-value-filter value)
- (let ((continuation (rep-continuation)))
- (if (or (null? value) (null-continuation? continuation))
- (continuation '())
- ((continuation-next-continuation continuation) (car value)))))
-\f
-(define (start-error-rep message irritant)
- (fluid-let ((error-message message)
- (error-irritant irritant))
- (let ((environment (continuation-environment (rep-continuation))))
- (if (continuation-undefined-environment? environment)
- (*error-hook* (rep-environment) message irritant true)
- (*error-hook* environment message irritant false)))))
-
-(define (standard-error-hook environment message irritant
- substitute-environment?)
- (push-rep environment
- (let ((message (make-error-message message irritant)))
- (if substitute-environment?
- (lambda ()
- (message)
- (write-string "
-There is no environment available;
-using the current read-eval-print environment."))
- message))
- (standard-rep-prompt error-prompt)))
-
-(define ((make-error-message message irritant))
- (newline)
- (write-string message)
- (if (not (eq? irritant *the-non-printing-object*))
- (let ((out (write-to-string irritant 40)))
- (write-char #\Space)
- (write-string (cdr out))
- (if (car out) (write-string "..."))))
- (if *error-decision-hook* (*error-decision-hook*)))
-\f
-;;;; Error Handlers
-
-;;; All error handlers have the following form:
-
-(define ((make-error-handler direction-alist operator-alist
- default-handler default-combination-handler)
- expression)
- ((let direction-loop ((alist direction-alist))
- (cond ((null? alist)
- (cond ((combination? expression)
- (let ((operator (combination-operator* expression)))
- (let operator-loop ((alist operator-alist))
- (cond ((null? alist) default-combination-handler)
- ((memq operator (caar alist)) (cdar alist))
- (else (operator-loop (cdr alist)))))))
- (else default-handler)))
- (((caar alist) expression) (cdar alist))
- (else (direction-loop (cdr alist)))))
- expression))
-
-;;; Then there are several methods for modifying the behavior of a
-;;; given error handler.
-
-(define expression-specific-adder)
-(define operation-specific-adder)
-
-(let ()
- (define (((alist-adder name) error-handler) filter receiver)
- (let ((environment
- (procedure-environment (wrapped-error-handler error-handler))))
- (lexical-assignment environment
- name
- (cons (cons filter receiver)
- (lexical-reference environment name)))))
-
- (set! expression-specific-adder
- (alist-adder 'DIRECTION-ALIST))
- (set! operation-specific-adder
- (alist-adder 'OPERATOR-ALIST)))
-
-(define default-expression-setter)
-(define default-combination-setter)
-
-(let ()
- (define (((set-default name) error-handler) receiver)
- (lexical-assignment
- (procedure-environment (wrapped-error-handler error-handler))
- name
- receiver))
-
- (set! default-expression-setter
- (set-default 'DEFAULT-HANDLER))
- (set! default-combination-setter
- (set-default 'DEFAULT-COMBINATION-HANDLER)))
-\f
-;;;; Error Vector
-
-;;; Initialize the error vector to the default state:
-
-(define (error-code-or-name code)
- (let ((v (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))))
- (if (or (>= code (vector-length v))
- (null? (vector-ref v code)))
- code
- (vector-ref v code))))
-
-(define (default-error-handler expression)
- (start-error-rep "Anomalous error -- get a wizard"
- (error-code-or-name *error-code*)))
-
-(define system-error-vector
- (make-initialized-vector number-of-microcode-errors
- (lambda (error-code)
- (error-handler-wrapper
- (make-error-handler '()
- '()
- default-error-handler
- default-error-handler)))))
-
-;;; Use this procedure to displace the default handler completely.
-
-(define (define-total-error-handler error-name handler)
- (vector-set! system-error-vector
- (microcode-error error-name)
- (error-handler-wrapper handler)))
-
-;;; It will be installed later.
-
-(define (install)
- (set! *error-hook* standard-error-hook)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR)
- system-error-vector)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'ERROR-PROCEDURE)
- error-procedure-handler)
- (vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE)
- error-from-compiled-code)
- (set-fixed-objects-vector! (get-fixed-objects-vector)))
-\f
-;;;; Error Definers
-
-(define ((define-definer type definer) error-name . args)
- (apply definer
- (type (vector-ref system-error-vector (microcode-error error-name)))
- args))
-
-(define ((define-specific-error error-name message) filter selector)
- ((cond ((pair? filter) define-operation-specific-error)
- (else define-expression-specific-error))
- error-name filter message selector))
-
-(define define-expression-specific-error
- (define-definer expression-specific-adder
- (lambda (adder filter message selector)
- (adder filter (expression-error-rep message selector)))))
-
-(define define-operation-specific-error
- (define-definer operation-specific-adder
- (lambda (adder filter message selector)
- (adder filter (combination-error-rep message selector)))))
-
-(define define-operand-error
- (define-definer default-combination-setter
- (lambda (setter message selector)
- (setter (combination-error-rep message selector)))))
-
-(define define-operator-error
- (define-definer default-combination-setter
- (lambda (setter message)
- (setter (expression-error-rep message combination-operator*)))))
-
-(define define-combination-error
- (define-definer default-combination-setter
- (lambda (setter message selector)
- (setter (expression-error-rep message selector)))))
-
-(define define-default-error
- (define-definer default-expression-setter
- (lambda (setter message selector)
- (setter (expression-error-rep message selector)))))
-
-(define ((expression-error-rep message selector) expression)
- (start-error-rep message (selector expression)))
-
-(define ((combination-error-rep message selector) combination)
- (start-error-rep
- (string-append message " "
- (let ((out (write-to-string (selector combination) 40)))
- (if (car out)
- (string-append (cdr out) "...")
- (cdr out)))
- "\nwithin procedure")
- (combination-operator* combination)))
-\f
-;;;; Combination Operations
-
-;;; Combinations coming out of the continuation parser are either all
-;;; unevaluated, or all evaluated, or all operands evaluated and the
-;;; operator undefined. Thus we must be careful about unwrapping
-;;; the components when necessary. In practice, it turns out that
-;;; all but one of the interesting errors happen at the application
-;;; point, at which all of the combination's components are evaluated.
-
-(define (combination-operator* combination)
- (unwrap-evaluated-object (combination-operator combination)))
-
-(define ((combination-operand selector) combination)
- (unwrap-evaluated-object (selector (combination-operands combination))))
-
-(define combination-first-operand (combination-operand first))
-(define combination-second-operand (combination-operand second))
-(define combination-third-operand (combination-operand third))
-
-(define (combination-operands* combination)
- (map unwrap-evaluated-object (combination-operands combination)))
-
-(define (unwrap-evaluated-object object)
- (if (continuation-evaluated-object? object)
- (continuation-evaluated-object-value object)
- (error "Not evaluated -- get a wizard" unwrap-evaluated-object object)))
-\f
-;;;; Environment Operation Errors
-
-(define define-unbound-variable-error
- (define-specific-error 'UNBOUND-VARIABLE
- "Unbound Variable"))
-
-(define-unbound-variable-error variable? variable-name)
-(define-unbound-variable-error access? access-name)
-(define-unbound-variable-error assignment? assignment-name)
-(define-unbound-variable-error
- (list (make-primitive-procedure 'LEXICAL-REFERENCE)
- (make-primitive-procedure 'LEXICAL-ASSIGNMENT))
- combination-second-operand)
-
-(define-unbound-variable-error
- (list (make-primitive-procedure 'ADD-FLUID-BINDING! true))
- (lambda (obj)
- (let ((object (combination-second-operand obj)))
- (cond ((variable? object) (variable-name object))
- ((symbol? object) object)
- (else (error "Handler has bad object -- GET-A-WIZARD" object))))))
-
-(define define-unassigned-variable-error
- (define-specific-error 'UNASSIGNED-VARIABLE
- "Unassigned Variable"))
-
-(define-unassigned-variable-error variable? variable-name)
-(define-unassigned-variable-error access? access-name)
-(define-unassigned-variable-error
- (list (make-primitive-procedure 'LEXICAL-REFERENCE))
- combination-second-operand)
-
-(define define-bad-frame-error
- (define-specific-error 'BAD-FRAME
- "Illegal Environment Frame"))
-
-(define-bad-frame-error access? access-environment)
-(define-bad-frame-error in-package? in-package-environment)
-
-#|
-(define define-assignment-to-procedure-error
- (define-specific-error 'ASSIGN-LAMBDA-NAME
- "Attempt to assign procedure's name"))
-
-(define-assignment-to-procedure-error assignment? assignment-name)
-(define-assignment-to-procedure-error definition? definition-name)
-(define-assignment-to-procedure-error
- (list (make-primitive-procedure 'LEXICAL-ASSIGNMENT)
- (make-primitive-procedure 'LOCAL-ASSIGNMENT)
- (make-primitive-procedure 'ADD-FLUID-BINDING! true)
- (make-primitive-procedure 'MAKE-FLUID-BINDING! true))
- combination-second-operand)
-|#
-\f
-;;;; Application Errors
-
-(define-operator-error 'UNDEFINED-PROCEDURE
- "Application of Non-Procedure Object")
-
-(define-operator-error 'UNDEFINED-PRIMITIVE-OPERATION
- "Undefined Primitive Procedure")
-
-(define-operator-error 'UNIMPLEMENTED-PRIMITIVE
- "Unimplemented Primitive Procedure")
-
-(define-operand-error 'WRONG-NUMBER-OF-ARGUMENTS
- "Wrong Number of Arguments"
- (lambda (combination)
- (length (combination-operands* combination))))
-
-(let ((make
- (lambda (wta-error-code bra-error-code position-string
- position-selector)
- (let ((ap-string (string-append position-string " argument position"))
- (selector (combination-operand position-selector)))
- (define-operand-error wta-error-code
- (string-append "Illegal datum in " ap-string)
- selector)
- (define-operand-error bra-error-code
- (string-append "Datum out of range in " ap-string)
- selector)))))
- (make 'WRONG-TYPE-ARGUMENT-0 'BAD-RANGE-ARGUMENT-0 "first" first)
- (make 'WRONG-TYPE-ARGUMENT-1 'BAD-RANGE-ARGUMENT-1 "second" second)
- (make 'WRONG-TYPE-ARGUMENT-2 'BAD-RANGE-ARGUMENT-2 "third" third)
- (make 'WRONG-TYPE-ARGUMENT-3 'BAD-RANGE-ARGUMENT-3 "fourth" fourth)
- (make 'WRONG-TYPE-ARGUMENT-4 'BAD-RANGE-ARGUMENT-4 "fifth" fifth)
- (make 'WRONG-TYPE-ARGUMENT-5 'BAD-RANGE-ARGUMENT-5 "sixth" sixth)
- (make 'WRONG-TYPE-ARGUMENT-6 'BAD-RANGE-ARGUMENT-6 "seventh" seventh)
- (make 'WRONG-TYPE-ARGUMENT-7 'BAD-RANGE-ARGUMENT-7 "eighth" eighth)
- (make 'WRONG-TYPE-ARGUMENT-8 'BAD-RANGE-ARGUMENT-8
- "ninth" (lambda (list) (general-car-cdr list #x1400)))
- (make 'WRONG-TYPE-ARGUMENT-9 'BAD-RANGE-ARGUMENT-9
- "tenth" (lambda (list) (general-car-cdr list #x3000))))
-
-(define-operand-error 'FAILED-ARG-1-COERCION
- "Argument 1 cannot be coerced to floating point"
- combination-first-operand)
-
-(define-operand-error 'FAILED-ARG-2-COERCION
- "Argument 2 cannot be coerced to floating point"
- combination-second-operand)
-\f
-;;;; Primitive Operator Errors
-
-(define-operation-specific-error 'FASL-FILE-TOO-BIG
- (list (make-primitive-procedure 'BINARY-FASLOAD))
- "Not enough room to Fasload"
- combination-first-operand)
-
-(define-operation-specific-error 'FASL-FILE-BAD-DATA
- (list (make-primitive-procedure 'BINARY-FASLOAD))
- "Fasload file would not relocate correctly"
- combination-first-operand)
-
-#|
-(define-operation-specific-error 'RAN-OUT-OF-HASH-NUMBERS
- (list (make-primitive-procedure 'OBJECT-HASH))
- "Hashed too many objects -- get a wizard"
- combination-first-operand)
-|#
-
-;;; This will trap any external-primitive errors that
-;;; aren't caught by special handlers.
-
-(define-operator-error 'EXTERNAL-RETURN
- "Error during External Application")
-
-(define-operation-specific-error 'EXTERNAL-RETURN
- (list (make-primitive-procedure 'FILE-OPEN-CHANNEL))
- "Unable to open file"
- combination-first-operand)
-
-(define-operation-specific-error 'OUT-OF-FILE-HANDLES
- (list (make-primitive-procedure 'FILE-OPEN-CHANNEL))
- "Too many open files"
- combination-first-operand)
-\f
-;;;; SCODE Syntax Errors
-
-;;; This error gets an unevaluated combination, but it doesn't ever
-;;; look at the components, so it doesn't matter.
-
-(define define-broken-variable-error
- (define-specific-error 'BROKEN-CVARIABLE
- "Broken Compiled Variable -- get a wizard"))
-
-(define-broken-variable-error variable? variable-name)
-(define-broken-variable-error assignment? assignment-name)
-\f
-;;;; System Errors
-
-(define-total-error-handler 'BAD-ERROR-CODE
- (lambda (error-code)
- (start-error-rep "Bad Error Code -- get a wizard"
- (error-code-or-name error-code))))
-
-(define-default-error 'BAD-INTERRUPT-CODE
- "Illegal Interrupt Code -- get a wizard"
- identity-procedure)
-
-(define-default-error 'EXECUTE-MANIFEST-VECTOR
- "Attempt to execute Manifest Vector -- get a wizard"
- identity-procedure)
-
-(define-total-error-handler 'WRITE-INTO-PURE-SPACE
- (lambda (error-code)
- (newline)
- (write-string "Automagically IMPURIFYing an object....")
- (impurify (combination-first-operand
- (continuation-expression (rep-continuation))))))
-
-(define-default-error 'UNDEFINED-USER-TYPE
- "Undefined Type Code -- get a wizard"
- identity-procedure)
-
-(define-default-error 'INAPPLICABLE-CONTINUATION
- "Inapplicable continuation -- get a wizard"
- identity-procedure)
-
-(define-default-error 'COMPILED-CODE-ERROR
- "Compiled code error -- get a wizard"
- identity-procedure)
-
-(define-default-error 'FLOATING-OVERFLOW
- "Floating point overflow"
- identity-procedure)
-
-;;; end ERROR-SYSTEM package.
-))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/events.scm,v 13.42 1987/03/17 18:49:40 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Event Distribution
-
-(declare (usual-integrations))
-\f
-(define make-event-distributor)
-(define event-distributor?)
-(define add-event-receiver!)
-(define remove-event-receiver!)
-
-(let ((:type (make-named-tag "EVENT-DISTRIBUTOR")))
- (set! make-event-distributor
- (named-lambda (make-event-distributor)
- (define receivers '())
- (define queue-head '())
- (define queue-tail '())
- (define event-in-progress? false)
- (lambda arguments
- (if (null? queue-head)
- (begin (set! queue-head (list arguments))
- (set! queue-tail queue-head))
- (begin (set-cdr! queue-tail (list arguments))
- (set! queue-tail (cdr queue-tail))))
- (if (not (set! event-in-progress? true))
- (begin (let ((arguments (car queue-head)))
- (set! queue-head (cdr queue-head))
- (let loop ((receivers receivers))
- (if (not (null? receivers))
- (begin (apply (car receivers) arguments)
- (loop (cdr receivers))))))
- (set! event-in-progress? false))))))
-
- (set! event-distributor?
- (named-lambda (event-distributor? object)
- (and (compound-procedure? object)
- (let ((e (procedure-environment object)))
- (and (not (lexical-unreferenceable? e ':TYPE))
- (eq? (access :type e) :type)
- e)))))
-
- (define ((make-receiver-modifier name operation)
- event-distributor event-receiver)
- (let ((e (event-distributor? event-distributor)))
- (if (not e)
- (error "Not an event distributor" name event-distributor))
- (without-interrupts
- (lambda ()
- (set! (access receivers e)
- (operation event-receiver (access receivers e)))))))
-
- (set! add-event-receiver!
- (make-receiver-modifier 'ADD-EVENT-RECEIVER!
- (lambda (receiver receivers)
- (append! receivers (list receiver)))))
-
- (set! remove-event-receiver!
- (make-receiver-modifier 'REMOVE-EVENT-RECEIVER! delq!))
-
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/format.scm,v 13.42 1987/03/17 18:49:48 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Output Formatter
-
-(declare (usual-integrations))
-
-;;; Please don't believe this implementation! I don't like either the
-;;; calling interface or the control string syntax, but I need the
-;;; functionality pretty badly and I don't have the time to think
-;;; about all of that right now -- CPH.
-
-(define format)
-(let ()
-\f
-;;;; Top Level
-
-(set! format
-(named-lambda (format port-or-string . arguments)
- (cond ((null? port-or-string)
- (if (and (not (null? arguments))
- (string? (car arguments)))
- (with-output-to-string
- (lambda ()
- (format-start (car arguments) (cdr arguments))))
- (error "Missing format string" 'FORMAT)))
- ((string? port-or-string)
- (format-start port-or-string arguments)
- *the-non-printing-object*)
- ((output-port? port-or-string)
- (if (and (not (null? arguments))
- (string? (car arguments)))
- (begin (with-output-to-port port-or-string
- (lambda ()
- (format-start (car arguments) (cdr arguments))))
- *the-non-printing-object*)
- (error "Missing format string" 'FORMAT)))
- (else
- (error "Unrecognizable first argument" 'FORMAT
- port-or-string)))))
-
-(define (format-start string arguments)
- (format-loop string arguments)
- ((access :flush-output *current-output-port*)))
-
-(declare (integrate *unparse-char *unparse-string *unparse-object))
-
-(define (*unparse-char char)
- (declare (integrate char))
- ((access :write-char *current-output-port*) char))
-
-(define (*unparse-string string)
- (declare (integrate string))
- ((access :write-string *current-output-port*) string))
-
-(define (*unparse-object object)
- (declare (integrate object))
- ((access unparse-object unparser-package) object *current-output-port*))
-\f
-(define (format-loop string arguments)
- (let ((index (string-find-next-char string #\~)))
- (cond (index
- (if (not (zero? index))
- (*unparse-string (substring string 0 index)))
- (parse-dispatch (string-tail string (1+ index))
- arguments
- '()
- '()
- (lambda (remaining-string remaining-arguments)
- (format-loop remaining-string
- remaining-arguments))))
- ((null? arguments)
- (*unparse-string string))
- (else
- (error "Too many arguments" 'FORMAT arguments)))))
-
-(define (parse-dispatch string supplied-arguments parsed-arguments modifiers
- receiver)
- ((vector-ref format-dispatch-table (vector-8b-ref string 0))
- string
- supplied-arguments
- parsed-arguments
- modifiers
- receiver))
-\f
-;;;; Argument Parsing
-
-(define ((format-wrapper operator)
- string supplied-arguments parsed-arguments modifiers receiver)
- ((apply operator modifiers (reverse! parsed-arguments))
- (string-tail string 1)
- supplied-arguments
- receiver))
-
-(define ((parse-modifier keyword)
- string supplied-arguments parsed-arguments modifiers receiver)
- (parse-dispatch (string-tail string 1)
- supplied-arguments
- parsed-arguments
- (cons keyword modifiers)
- receiver))
-
-(define (parse-digit string supplied-arguments parsed-arguments modifiers
- receiver)
- (let accumulate ((acc (char->digit (string-ref string 0) 10)) (i 1))
- (if (char-numeric? (string-ref string i))
- (accumulate (+ (* acc 10) (char->digit (string-ref string i) 10))
- (1+ i))
- (parse-dispatch (string-tail string i)
- supplied-arguments
- (cons acc parsed-arguments)
- modifiers
- receiver))))
-
-(define (parse-ignore string supplied-arguments parsed-arguments modifiers
- receiver)
- (parse-dispatch (string-tail string 1) supplied-arguments parsed-arguments
- modifiers receiver))
-
-(define (parse-arity string supplied-arguments parsed-arguments modifiers
- receiver)
- (parse-dispatch (string-tail string 1)
- supplied-arguments
- (cons (length supplied-arguments) parsed-arguments)
- modifiers
- receiver))
-
-(define (parse-argument string supplied-arguments parsed-arguments modifiers
- receiver)
- (parse-dispatch (string-tail string 1)
- (cdr supplied-arguments)
- (cons (car supplied-arguments) parsed-arguments)
- modifiers
- receiver))
-
-(define (string-tail string index)
- (substring string index (string-length string)))
-\f
-;;;; Formatters
-
-(define (((format-insert-character character) modifiers #!optional n)
- string arguments receiver)
- (if (unassigned? n)
- (*unparse-char character)
- (let loop ((i 0))
- (if (not (= i n))
- (begin (*unparse-char character)
- (loop (1+ i))))))
- (receiver string arguments))
-
-(define format-insert-return (format-insert-character char:newline))
-(define format-insert-tilde (format-insert-character #\~))
-(define format-insert-space (format-insert-character #\Space))
-
-(define ((format-ignore-comment modifiers) string arguments receiver)
- (receiver (substring string
- (1+ (string-find-next-char string char:newline))
- (string-length string))
- arguments))
-
-(define format-ignore-whitespace)
-(let ()
-
-(define newline-string
- (char->string char:newline))
-
-(define (eliminate-whitespace string)
- (let ((limit (string-length string)))
- (let loop ((n 0))
- (cond ((= n limit) "")
- ((let ((char (string-ref string n)))
- (and (char-whitespace? char)
- (not (char=? char char:newline))))
- (loop (1+ n)))
- (else
- (substring string n limit))))))
-
-(set! format-ignore-whitespace
-(named-lambda ((format-ignore-whitespace modifiers) string arguments receiver)
- (receiver (cond ((null? modifiers) (eliminate-whitespace string))
- ((memq 'AT modifiers)
- (string-append newline-string
- (eliminate-whitespace string)))
- (else string))
- arguments)))
-)
-\f
-(define ((format-string modifiers #!optional n-columns)
- string arguments receiver)
- (if (null? arguments)
- (error "Too few arguments" 'FORMAT string))
- (if (unassigned? n-columns)
- (*unparse-string (car arguments))
- (unparse-string-into-fixed-size (car arguments) false
- n-columns modifiers))
- (receiver string (cdr arguments)))
-
-(define ((format-object modifiers #!optional n-columns)
- string arguments receiver)
- (if (null? arguments)
- (error "Too few arguments" 'FORMAT string))
- (if (unassigned? n-columns)
- (*unparse-object (car arguments))
- (unparse-object-into-fixed-size (car arguments) n-columns modifiers))
- (receiver string (cdr arguments)))
-
-(define ((format-code modifiers #!optional n-columns)
- string arguments receiver)
- (if (null? arguments)
- (error "Too few arguments" 'FORMAT string))
- (if (unassigned? n-columns)
- (*unparse-object (unsyntax (car arguments)))
- (unparse-object-into-fixed-size (unsyntax (car arguments))
- n-columns
- modifiers))
- (receiver string (cdr arguments)))
-
-(define (unparse-object-into-fixed-size object n-columns modifiers)
- (let ((output (write-to-string object n-columns)))
- (unparse-string-into-fixed-size (cdr output)
- (car output)
- n-columns
- modifiers)))
-
-(define (unparse-string-into-fixed-size string already-truncated?
- n-columns modifiers)
- (let ((padding (- n-columns (string-length string))))
- (cond ((and (zero? padding) (not already-truncated?))
- (*unparse-string string))
- ((positive? padding)
- (let ((pad-string (make-string padding #\Space)))
- (if (memq 'AT modifiers)
- (begin (*unparse-string string)
- (*unparse-string pad-string))
- (begin (*unparse-string pad-string)
- (*unparse-string string)))))
- ;; This is pretty random -- figure out something better.
- ((memq 'COLON modifiers)
- (*unparse-string (substring string 0 (- n-columns 4)))
- (*unparse-string " ..."))
- (else (*unparse-string (substring string 0 n-columns))))))
-\f
-;;;; Dispatcher Setup
-
-(define format-dispatch-table
- (make-initialized-vector
- 128
- (lambda (character)
- (lambda (string supplied-arguments parsed-arguments modifiers receiver)
- (error "Unknown formatting character" 'FORMAT character)))))
-
-(define (add-dispatcher! char dispatcher)
- (if (char-alphabetic? char)
- (begin (vector-set! format-dispatch-table
- (char->ascii (char-downcase char))
- dispatcher)
- (vector-set! format-dispatch-table
- (char->ascii (char-upcase char))
- dispatcher))
- (vector-set! format-dispatch-table
- (char->ascii char)
- dispatcher)))
-
-(add-dispatcher! #\0 parse-digit)
-(add-dispatcher! #\1 parse-digit)
-(add-dispatcher! #\2 parse-digit)
-(add-dispatcher! #\3 parse-digit)
-(add-dispatcher! #\4 parse-digit)
-(add-dispatcher! #\5 parse-digit)
-(add-dispatcher! #\6 parse-digit)
-(add-dispatcher! #\7 parse-digit)
-(add-dispatcher! #\8 parse-digit)
-(add-dispatcher! #\9 parse-digit)
-(add-dispatcher! #\, parse-ignore)
-(add-dispatcher! #\# parse-arity)
-(add-dispatcher! #\V parse-argument)
-(add-dispatcher! #\@ (parse-modifier 'AT))
-(add-dispatcher! #\: (parse-modifier 'COLON))
-\f
-;;;
-;;; (format format-string arg arg ...)
-;;; (format port format-string arg arg ...)
-;;;
-;;; Format strings are normally interpreted literally, except that
-;;; certain escape sequences allow insertion of computed values. The
-;;; following escape sequences are recognized:
-;;;
-;;; ~n% inserts n newlines
-;;; ~n~ inserts n tildes
-;;; ~nX inserts n spaces
-;;;
-;;; ~<c> inserts the next argument.
-;;; ~n<c> right justifies the argument in a field of size n.
-;;; ~n@<c> left justifies the argument in a field of size n.
-;;;
-;;; where <c> may be:
-;;; S meaning the argument is a string and should be used literally.
-;;; O meaning the argument is an object and should be printed first.
-;;; C meaning the object is SCode and should be unsyntaxed and printed.
-;;;
-;;; If the resulting string is too long, it is truncated.
-;;; ~n:<c> or ~n:@<c> means print trailing dots when truncating.
-;;;
-
-(add-dispatcher! #\% (format-wrapper format-insert-return))
-(add-dispatcher! #\~ (format-wrapper format-insert-tilde))
-(add-dispatcher! #\X (format-wrapper format-insert-space))
-(add-dispatcher! #\; (format-wrapper format-ignore-comment))
-(add-dispatcher! char:newline (format-wrapper format-ignore-whitespace))
-(add-dispatcher! #\S (format-wrapper format-string))
-(add-dispatcher! #\O (format-wrapper format-object))
-(add-dispatcher! #\C (format-wrapper format-code))
-
-;;; end LET.
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 13.43 1987/03/18 20:07:23 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Garbage Collector
-
-(declare (usual-integrations)
- (integrate-primitive-procedures
- garbage-collect primitive-purify primitive-impurify primitive-fasdump
- set-interrupt-enables! enable-interrupts! primitive-gc-type pure?
- get-next-constant call-with-current-continuation hunk3-cons
- set-fixed-objects-vector! tty-write-char tty-write-string exit))
-\f
-(define add-gc-daemon!)
-(define gc-flip)
-(define purify)
-(define impurify)
-(define fasdump)
-(define suspend-world)
-(define set-default-gc-safety-margin!)
-
-(define garbage-collector-package
- (make-environment
-
-(define default-safety-margin 4500)
-
-;; SET-DEFAULT-GC-SAFETY-MARGIN! changes the amount of memory
-;; saved from the heap to allow the GC handler to run.
-
-(set! set-default-gc-safety-margin!
-(named-lambda (set-default-gc-safety-margin! #!optional margin)
- (if (or (unassigned? margin) (null? margin))
- default-safety-margin
- (begin (set! default-safety-margin margin)
- (gc-flip margin)))))
-
-;;;; Cold Load GC
-
-(define (reset)
- (enable-interrupts! interrupt-mask-none))
-
-;;; User call -- optionally overrides the default GC safety
-;;; margin for this flip only.
-
-(set! gc-flip
-(named-lambda (gc-flip #!optional new-safety-margin)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (old-interrupt-mask)
- (garbage-collect
- (if (unassigned? new-safety-margin)
- default-safety-margin
- new-safety-margin))))))
-
-(vector-set! (vector-ref (get-fixed-objects-vector) 1)
- 2 ;Local Garbage Collection Interrupt
- (named-lambda (gc-interrupt interrupt-code interrupt-enables)
- (gc-flip Default-Safety-Margin)))
-
-(vector-set! (vector-ref (get-fixed-objects-vector) 1)
- 0 ;Local Stack Overflow Interrupt
- (named-lambda (stack-overflow-interrupt interrupt-code
- interrupt-enables)
- (stack-overflow)
- (set-interrupt-enables! interrupt-enables)))
-\f
-;;; This variable is clobbered by GCSTAT.
-(define (stack-overflow)
- (tty-write-char char:newline)
- (tty-write-string "Stack overflow!")
- (tty-write-char char:newline)
- (exit))
-
-(vector-set! (get-fixed-objects-vector)
- #x0C
- (named-lambda (hardware-trap-handler escape-code)
- (hardware-trap)))
-
-;;; This is clobbered also by GCSTAT.
-(define (hardware-trap)
- (tty-write-char char:newline)
- (tty-write-string "Hardware trap")
- (tty-write-char char:newline)
- (exit))
-
-;;; The GC daemon is invoked by the microcode whenever there is a need.
-;;; All we provide here is a trivial extension mechanism.
-
-(vector-set! (get-fixed-objects-vector)
- #x0B
- (named-lambda (gc-daemon)
- (trigger-daemons gc-daemons)))
-
-(set-fixed-objects-vector! (get-fixed-objects-vector))
-
-(define (trigger-daemons daemons . extra-args)
- (let loop ((daemons daemons))
- (if (not (null? daemons))
- (begin (apply (car daemons) extra-args)
- (loop (cdr daemons))))))
-
-(define gc-daemons '())
-
-(set! add-gc-daemon!
-(named-lambda (add-gc-daemon! daemon)
- (if (not (memq daemon gc-daemons))
- (set! gc-daemons (cons daemon gc-daemons)))))
-
-(reset)
-\f
-;;;; "GC-like" Primitives
-
-;; Purify an item -- move it into pure space and clean everything
-;; by doing a gc-flip
-
-(set! purify
-(named-lambda (purify item #!optional really-pure?)
- (if (primitive-purify item
- (if (unassigned? really-pure?)
- false
- really-pure?))
- item
- (error "Not enough room in constant space" purify item))))
-
-(set! impurify
-(named-lambda (impurify object)
- (if (or (zero? (primitive-gc-type object))
- (not (pure? object)))
- object
- (primitive-impurify object))))
-
-(set! fasdump
-(named-lambda (fasdump object filename)
- (let ((filename (canonicalize-output-filename filename))
- (port (rep-output-port)))
- (newline port)
- (write-string "FASDumping " port)
- (write filename port)
- (if (not (primitive-fasdump object filename false))
- (error "Object is too large to be dumped" fasdump object))
- (write-string " -- done" port))
- object))
-\f
-(set! suspend-world
-(named-lambda (suspend-world suspender after-suspend after-restore)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (ie)
- ((call-with-current-continuation
- (lambda (cont)
- (let ((fixed-objects-vector (get-fixed-objects-vector))
- (dynamic-state (current-dynamic-state)))
- (fluid-let ()
- (call-with-current-continuation
- (lambda (restart)
- (gc-flip)
- (suspender restart)
- (cont after-suspend)))
- (set-fixed-objects-vector! fixed-objects-vector)
- (set-current-dynamic-state! dynamic-state)
- (reset)
- ((access snarf-version microcode-system))
- (reset-keyboard-interrupt-dispatch-table!)
- (set! *rep-keyboard-map* (keyboard-interrupt-dispatch-table))
- ((access reset! primitive-io))
- ((access reset! working-directory-package))
- after-restore))))
- ie)))))
-
-;;; end GARBAGE-COLLECTOR-PACKAGE.
-))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcstat.scm,v 13.43 1987/04/13 18:43:38 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; GC Statistics
-
-(declare (usual-integrations))
-
-(define gctime)
-(define gc-statistics)
-(define gc-history-mode)
-
-(define gc-statistics-package
- (make-environment
-\f
-;;;; Statistics Hooks
-
-(define (gc-start-hook) 'DONE)
-(define (gc-finish-hook state) 'DONE)
-
-(define ((make-flip-hook old-flip) . More)
- (with-interrupts-reduced interrupt-mask-none
- (lambda (Old-Interrupt-Mask)
- (measure-interval
- false ;i.e. do not count the interval in RUNTIME.
- (lambda (start-time)
- (let ((old-state (gc-start-hook)))
- (let ((new-space-remaining (primitive-datum (apply old-flip more))))
- (gc-finish-hook old-state)
- (if (< new-space-remaining 4096)
- (abort->nearest
- (standard-rep-message "Aborting: Out of memory!")))
- (lambda (end-time)
- (statistics-flip start-time
- end-time
- new-space-remaining)
- new-space-remaining))))))))
-\f
-;;;; Statistics Collector
-
-(define meter)
-(define total-gc-time)
-(define last-gc-start)
-(define last-gc-end)
-
-(define (statistics-reset!)
- (set! meter 1)
- (set! total-gc-time 0)
- (set! last-gc-start false)
- (set! last-gc-end (system-clock))
- (reset-recorder! '()))
-
-(define (statistics-flip start-time end-time heap-left)
- (let ((statistic
- (vector meter
- start-time end-time
- last-gc-start last-gc-end
- heap-left)))
- (set! meter (1+ meter))
- (set! total-gc-time (+ (- end-time start-time) total-gc-time))
- (set! last-gc-start start-time)
- (set! last-gc-end end-time)
- (record-statistic! statistic)))
-
-(set! gctime (named-lambda (gctime) total-gc-time))
-\f
-;;;; Statistics Recorder
-
-(define last-statistic)
-(define history)
-
-(define (reset-recorder! old)
- (set! last-statistic false)
- (reset-history! old))
-
-(define (record-statistic! statistic)
- (set! last-statistic statistic)
- (record-in-history! statistic))
-
-(set! gc-statistics
- (named-lambda (gc-statistics)
- (let ((history (get-history)))
- (if (null? history)
- (if last-statistic
- (list last-statistic)
- '())
- history))))
-\f
-;;;; History Modes
-
-(define reset-history!)
-(define record-in-history!)
-(define get-history)
-(define history-mode)
-
-(set! gc-history-mode
- (named-lambda (gc-history-mode #!optional new-mode)
- (let ((old-mode history-mode))
- (if (not (unassigned? new-mode))
- (let ((old-history (get-history)))
- (set-history-mode! new-mode)
- (reset-history! old-history)))
- old-mode)))
-
-(define (set-history-mode! mode)
- (let ((entry (assq mode history-modes)))
- (if (not entry)
- (error "Bad mode name" 'SET-HISTORY-MODE! mode))
- ((cdr entry))
- (set! history-mode (car entry))))
-
-(define history-modes
- `((NONE . ,(named-lambda (none:install-history!)
- (set! reset-history! none:reset-history!)
- (set! record-in-history! none:record-in-history!)
- (set! get-history none:get-history)))
- (BOUNDED . ,(named-lambda (bounded:install-history!)
- (set! reset-history! bounded:reset-history!)
- (set! record-in-history! bounded:record-in-history!)
- (set! get-history bounded:get-history)))
- (UNBOUNDED . ,(named-lambda (unbounded:install-history!)
- (set! reset-history! unbounded:reset-history!)
- (set! record-in-history! unbounded:record-in-history!)
- (set! get-history unbounded:get-history)))))
-\f
-;;; NONE
-
-(define (none:reset-history! old)
- (set! history '()))
-
-(define (none:record-in-history! item)
- 'DONE)
-
-(define (none:get-history)
- '())
-
-;;; BOUNDED
-
-(define history-size 8)
-
-(define (copy-to-size l size)
- (let ((max (length l)))
- (if (>= max size)
- (initial-segment l size)
- (append (initial-segment l max)
- (make-list (- size max) '())))))
-
-(define (bounded:reset-history! old)
- (set! history (apply circular-list (copy-to-size old history-size))))
-
-(define (bounded:record-in-history! item)
- (set-car! history item)
- (set! history (cdr history)))
-
-(define (bounded:get-history)
- (let loop ((scan (cdr history)))
- (cond ((eq? scan history) '())
- ((null? (car scan)) (loop (cdr scan)))
- (else (cons (car scan) (loop (cdr scan)))))))
-
-;;; UNBOUNDED
-
-(define (unbounded:reset-history! old)
- (set! history old))
-
-(define (unbounded:record-in-history! item)
- (set! history (cons item history)))
-
-(define (unbounded:get-history)
- (reverse history))
-\f
-;;;; Initialization
-
-(define (install!)
- (set-history-mode! 'BOUNDED)
- (statistics-reset!)
- (set! gc-flip (make-flip-hook gc-flip))
- (set! (access stack-overflow garbage-collector-package)
- (named-lambda (stack-overflow)
- (abort->nearest
- (standard-rep-message
- "Aborting: Maximum recursion depth exceeded!"))))
- (set! (access hardware-trap garbage-collector-package)
- (named-lambda (hardware-trap)
- (abort->nearest
- (standard-rep-message
- "Aborting: The hardware trapped!"))))
- (add-event-receiver! event:after-restore statistics-reset!))
-
-;;; end GC-STATISTICS-PACKAGE.
-))
-\f
-;;;; GC Notification
-
-(define toggle-gc-notification!)
-(define print-gc-statistics)
-(let ()
-
-(define normal-recorder '())
-
-(define (gc-notification statistic)
- (normal-recorder statistic)
- (with-output-to-port (rep-output-port)
- (lambda ()
- (print-statistic statistic))))
-
-(set! toggle-gc-notification!
-(named-lambda (toggle-gc-notification!)
- (if (null? normal-recorder)
- (begin (set! normal-recorder
- (access record-statistic! gc-statistics-package))
- (set! (access record-statistic! gc-statistics-package)
- gc-notification))
- (begin (set! (access record-statistic! gc-statistics-package)
- normal-recorder)
- (set! normal-recorder '())))
- *the-non-printing-object*))
-
-(set! print-gc-statistics
-(named-lambda (print-gc-statistics)
- (for-each print-statistic (gc-statistics))))
-
-(define (print-statistic statistic)
- (apply (lambda (meter
- this-gc-start this-gc-end
- last-gc-start last-gc-end
- heap-left)
- (let ((delta-time (- this-gc-end this-gc-start)))
- (newline) (write-string "GC #") (write meter)
- (write-string " took: ") (write delta-time)
- (write-string " (")
- (write (round (* (/ delta-time (- this-gc-end last-gc-end))
- 100)))
- (write-string "%) free: ") (write heap-left)))
- (vector->list statistic)))
-
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gensym.scm,v 13.41 1987/01/23 00:13:48 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; GENSYM
-
-(declare (usual-integrations))
-\f
-(define (make-name-generator prefix)
- (let ((counter 0))
- (named-lambda (name-generator)
- (string->uninterned-symbol
- (string-append prefix
- (write-to-string
- (let ((n counter))
- (set! counter (1+ counter))
- n)))))))
-
-(define generate-uninterned-symbol
- (let ((name-counter 0)
- (name-prefix "G"))
- (define (get-number)
- (let ((result name-counter))
- (set! name-counter (1+ name-counter))
- result))
- (named-lambda (generate-uninterned-symbol #!optional argument)
- (if (not (unassigned? argument))
- (cond ((symbol? argument)
- (set! name-prefix (symbol->string argument)))
- ((integer? argument)
- (set! name-counter argument))
- (else
- (error "Bad argument: GENERATE-UNINTERNED-SYMBOL"
- argument))))
- (string->uninterned-symbol
- (string-append name-prefix (write-to-string (get-number)))))))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hash.scm,v 13.45 1987/02/15 15:43:06 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Object Hashing, populations, and 2D tables
-
-;;; The hashing code, and the population code below, depend on weak
-;;; conses supported by the microcode. In particular, both pieces of
-;;; code depend on the fact that the car of a weak cons becomes #F if
-;;; the object is garbage collected.
-
-;;; Important: This code must be rewritten for a parallel processor,
-;;; since two processors may be updating the data structures
-;;; simultaneously.
-
-(declare (usual-integrations))
-
-(add-event-receiver! event:after-restore gc-flip)
-\f
-;;;; Object hashing
-
-;;; How this works:
-
-;;; There are two tables, the hash table and the unhash table:
-
-;;; - The hash table associates objects to their hash numbers. The
-;;; entries are keyed according to the address (datum) of the object,
-;;; and thus must be recomputed after every relocation (ie. band
-;;; loading, garbage collection, etc.).
-
-;;; - The unhash table associates the hash numbers with the
-;;; corresponding objects. It is keyed according to the numbers
-;;; themselves.
-
-;;; In order to make the hash and unhash tables weakly hold the
-;;; objects hashed, the following mechanism is used:
-
-;;; The hash table, a vector, has a SNMV header before all the
-;;; buckets, and therefore the garbage collector will skip it and will
-;;; not relocate its buckets. It becomes invalid after a garbage
-;;; collection and the first thing the daemon does is clear it. Each
-;;; bucket is a normal alist with the objects in the cars, and the
-;;; numbers in the cdrs, thus assq can be used to find an object in
-;;; the bucket.
-
-;;; The unhash table, also a vector, holds the objects by means of
-;;; weak conses. These weak conses are the same as the pairs in the
-;;; buckets in the hash table, but with their type codes changed.
-;;; Each of the buckets in the unhash table is headed by an extra pair
-;;; whose car is usually #T. This pair is used by the splicing code.
-;;; The daemon treats buckets headed by #F differently from buckets
-;;; headed by #T. A bucket headed by #T is compressed: Those pairs
-;;; whose cars have disappeared are spliced out from the bucket. On
-;;; the other hand, buckets headed by #F are not compressed. The
-;;; intent is that while object-unhash is traversing a bucket, the
-;;; bucket is locked so that the daemon will not splice it out behind
-;;; object-unhash's back. Then object-unhash does not need to be
-;;; locked against garbage collection.
-\f
-(define (hash x)
- (if (eq? x false)
- 0
- (object-hash x)))
-
-(define (unhash n)
- (if (zero? n)
- false
- (or (object-unhash n)
- (error "unhash: Not a valid hash number" n))))
-
-(define (valid-hash-number? n)
- (or (zero? n)
- (object-unhash n)))
-
-(define object-hash)
-(define object-unhash)
-
-(let ((pair-type (microcode-type 'PAIR))
- (weak-cons-type (microcode-type 'WEAK-CONS))
- (snmv-type (microcode-type 'MANIFEST-SPECIAL-NM-VECTOR))
- (&make-object (make-primitive-procedure '&MAKE-OBJECT)))
- (declare (integrate-primitive-procedures &make-object))
-
-(define next-hash-number)
-(define hash-table-size)
-(define unhash-table)
-(define hash-table)
-
-(define (initialize-object-hash! size)
- (set! next-hash-number 1)
- (set! hash-table-size size)
- (set! unhash-table (vector-cons size '()))
- (set! hash-table (vector-cons (1+ size) '()))
- (vector-set! hash-table 0 (&make-object snmv-type size))
- (let initialize ((n 0))
- (if (< n size)
- (begin (vector-set! unhash-table n (cons true '()))
- (initialize (1+ n))))))
-\f
-;;; This is not dangerous because assq is a primitive and does not
-;;; cause consing. The rest of the consing (including that by the
-;;; interpreter) is a small bounded amount.
-
-(set! object-hash
-(named-lambda (object-hash object)
- (with-interrupt-mask interrupt-mask-none
- (lambda (ignore)
- (let* ((hash-index (1+ (modulo (primitive-datum object) hash-table-size)))
- (bucket (vector-ref hash-table hash-index))
- (association (assq object bucket)))
- (if association
- (cdr association)
- (let ((pair (cons object next-hash-number))
- (result next-hash-number)
- (unhash-bucket
- (vector-ref unhash-table
- (modulo next-hash-number hash-table-size))))
- (set! next-hash-number (1+ next-hash-number))
- (vector-set! hash-table hash-index (cons pair bucket))
- (set-cdr! unhash-bucket
- (cons (primitive-set-type weak-cons-type pair)
- (cdr unhash-bucket)))
- result)))))))
-
-;;; This is safe because it locks the garbage collector out only for a
-;;; little time, enough to tag the bucket being searched, so that the
-;;; daemon will not splice that bucket.
-
-(set! object-unhash
-(named-lambda (object-unhash number)
- (let ((index (modulo number hash-table-size)))
- (with-interrupt-mask interrupt-mask-none
- (lambda (ignore)
- (let ((bucket (vector-ref unhash-table index)))
- (set-car! bucket false)
- (let ((result
- (with-interrupt-mask interrupt-mask-gc-ok
- (lambda (ignore)
- (let loop ((l (cdr bucket)))
- (cond ((null? l) false)
- ((= number (system-pair-cdr (car l)))
- (system-pair-car (car l)))
- (else (loop (cdr l)))))))))
- (set-car! bucket true)
- result)))))))
-\f
-;;;; Rehash daemon
-
-;;; The following is dangerous because of the (unnecessary) consing
-;;; done by the interpreter while it executes the loops. It runs with
-;;; interrupts turned off. The (necessary) consing done by rehash is
-;;; not dangerous because at least that much storage was freed by the
-;;; garbage collector. To understand this, notice that the hash table
-;;; has a SNMV header, so the garbage collector does not trace the
-;;; hash table buckets, therefore freeing their storage. The header
-;;; is SNM rather than NM to make the buckets be relocated at band
-;;; load/restore time.
-
-;;; Until this code is compiled, and therefore safe, it is replaced by
-;;; a primitive. See the installation code below.
-
-#|
-(define (rehash weak-pair)
- (let ((index (1+ (modulo (primitive-datum (system-pair-car weak-pair))
- hash-table-size))))
- (vector-set! hash-table
- index
- (cons (primitive-set-type pair-type weak-pair)
- (vector-ref hash-table index)))))
-
-(define (cleanup n)
- (if (zero? n)
- 'DONE
- (begin (vector-set! hash-table n '())
- (cleanup (-1+ n)))))
-
-(define (rehash-gc-daemon)
- (cleanup hash-table-size)
- (let outer ((n (-1+ hash-table-size)))
- (if (negative? n)
- true
- (let ((bucket (vector-ref unhash-table n)))
- (if (car bucket)
- (let inner1 ((l1 bucket) (l2 (cdr bucket)))
- (cond ((null? l2) (outer (-1+ n)))
- ((eq? (system-pair-car (car l2)) false)
- (set-cdr! l1 (cdr l2))
- (inner1 l1 (cdr l1)))
- (else (rehash (car l2))
- (inner1 l2 (cdr l2)))))
- (let inner2 ((l (cdr bucket)))
- (cond ((null? l) (outer (-1+ n)))
- ((eq? (system-pair-car (car l)) false)
- (inner2 (cdr l)))
- (else (rehash (car l))
- (inner2 (cdr l))))))))))
-
-(add-gc-daemon! rehash-gc-daemon)
-|#
-\f
-(add-gc-daemon!
- (let ((primitive (make-primitive-procedure 'REHASH)))
- (lambda ()
- (primitive unhash-table hash-table))))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/histry.scm,v 13.45 1987/04/17 00:54:28 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; History Manipulation
-
-(declare (usual-integrations))
-\f
-(define max-subproblems 10)
-(define max-reductions 5)
-(define with-new-history)
-
-(define history-package
- (let ((set-current-history!
- (make-primitive-procedure 'SET-CURRENT-HISTORY!))
- (return-address-pop-from-compiled-code
- (make-return-address
- (microcode-return 'POP-FROM-COMPILED-CODE)))
-
- ;; VERTEBRA abstraction.
- (make-vertebra (make-primitive-procedure 'HUNK3-CONS))
- (vertebra-rib system-hunk3-cxr0)
- (shallower-vertebra system-hunk3-cxr2)
- (set-vertebra-rib! system-hunk3-set-cxr0!)
- (set-deeper-vertebra! system-hunk3-set-cxr1!)
- (set-shallower-vertebra! system-hunk3-set-cxr2!)
-
- ;; REDUCTION abstraction.
- (make-reduction (make-primitive-procedure 'HUNK3-CONS))
- (reduction-expression system-hunk3-cxr0)
- (reduction-environment system-hunk3-cxr1)
- (set-reduction-expression! system-hunk3-set-cxr0!)
- (set-reduction-environment! system-hunk3-set-cxr1!)
- (set-next-reduction! system-hunk3-set-cxr2!)
- )
-
-(declare (integrate-primitive-procedures
- (make-vertebra hunk3-cons)
- (vertebra-rib system-hunk3-cxr0)
- (shallower-vertebra system-hunk3-cxr2)
- (set-vertebra-rib! system-hunk3-set-cxr0!)
- (set-deeper-vertebra! system-hunk3-set-cxr1!)
- (set-shallower-vertebra! system-hunk3-set-cxr2!)
- (make-reduction hunk3-cons)
- (reduction-expression system-hunk3-cxr0)
- (reduction-environment system-hunk3-cxr1)
- (set-reduction-expression! system-hunk3-set-cxr0!)
- (set-reduction-environment! system-hunk3-set-cxr1!)
- (set-next-reduction! system-hunk3-set-cxr2!)))
-\f
-(define (deeper-vertebra vertebra)
- (make-object-safe (system-hunk3-cxr1 vertebra)))
-
-(define (marked-vertebra? vertebra)
- (object-dangerous? (system-hunk3-cxr1 vertebra)))
-
-(define (mark-vertebra! vertebra)
- (system-hunk3-set-cxr1!
- vertebra
- (make-object-dangerous (system-hunk3-cxr1 vertebra))))
-
-(define (unmark-vertebra! vertebra)
- (system-hunk3-set-cxr1! vertebra
- (make-object-safe (system-hunk3-cxr1 vertebra))))
-
-(define (next-reduction reduction)
- (make-object-safe (system-hunk3-cxr2 reduction)))
-
-(define (marked-reduction? reduction)
- (object-dangerous? (system-hunk3-cxr2 reduction)))
-
-(define (mark-reduction! reduction)
- (system-hunk3-set-cxr2!
- reduction
- (make-object-dangerous (system-hunk3-cxr2 reduction))))
-
-(define (unmark-reduction! reduction)
- (system-hunk3-set-cxr2! reduction
- (make-object-safe (system-hunk3-cxr2 reduction))))
-
-(define (link-vertebrae previous next)
- (set-deeper-vertebra! previous next)
- (set-shallower-vertebra! next previous))
-\f
-;;;; History Initialization
-
-(define (create-history depth width)
- (define (new-vertebra)
- (let ((head (make-reduction false false '())))
- (set-next-reduction!
- head
- (let reduction-loop ((n (-1+ width)))
- (if (zero? n)
- head
- (make-reduction false false (reduction-loop (-1+ n))))))
- (make-vertebra head '() '())))
-
- (cond ((or (not (integer? depth))
- (negative? depth))
- (error "Invalid Depth" 'CREATE-HISTORY depth))
- ((or (not (integer? width))
- (negative? width))
- (error "Invalid Width" 'CREATE-HISTORY width))
- (else
- (if (or (zero? depth) (zero? width))
- (begin (set! depth 1) (set! width 1)))
- (let ((head (new-vertebra)))
- (let subproblem-loop ((n (-1+ depth))
- (previous head))
- (if (zero? n)
- (link-vertebrae previous head)
- (let ((next (new-vertebra)))
- (link-vertebrae previous next)
- (subproblem-loop (-1+ n) next))))
- head))))
-\f
-;;; The PUSH-HISTORY! accounts for the pop which happens after
-;;; SET-CURRENT-HISTORY! is run.
-
-(set! with-new-history
- (named-lambda (with-new-history thunk)
- (set-current-history!
- (let ((history
- (push-history! (create-history max-subproblems
- max-reductions))))
- (if (zero? max-subproblems)
-
- ;; In this case, we want the history to appear empty,
- ;; so when it pops up, there is nothing in it.
- history
-
- ;; Otherwise, record a dummy reduction, which will appear
- ;; in the history.
- (begin
- (record-evaluation-in-history! history
- (scode-quote #F)
- system-global-environment)
- (push-history! history)))))
- (thunk)))
-
-;;;; Primitive History Operations
-;;; These operations mimic the actions of the microcode.
-;;; The history motion operations all return the new history.
-
-(define (record-evaluation-in-history! history expression environment)
- (let ((current-reduction (vertebra-rib history)))
- (set-reduction-expression! current-reduction expression)
- (set-reduction-environment! current-reduction environment)))
-
-(define (set-history-to-next-reduction! history)
- (let ((next-reduction (next-reduction (vertebra-rib history))))
- (set-vertebra-rib! history next-reduction)
- (unmark-reduction! next-reduction)
- history))
-
-(define (push-history! history)
- (let ((deeper-vertebra (deeper-vertebra history)))
- (mark-vertebra! deeper-vertebra)
- (mark-reduction! (vertebra-rib deeper-vertebra))
- deeper-vertebra))
-
-(define (pop-history! history)
- (unmark-vertebra! history)
- (shallower-vertebra history))
-\f
-;;;; Side-Effectless Examiners
-
-(define (history-transform history)
- (let loop ((current history))
- (cons current
- (if (marked-vertebra? current)
- (cons (delay (unfold-and-reverse-rib (vertebra-rib current)))
- (delay
- (let ((next (shallower-vertebra current)))
- (if (eq? next history)
- '()
- (loop next)))))
- '()))))
-
-(define (dummy-compiler-reduction? reduction)
- (and (marked-reduction? reduction)
- (null? (reduction-expression reduction))
- (eq? return-address-pop-from-compiled-code
- (reduction-environment reduction))))
-
-(define (unfold-and-reverse-rib rib)
- (let loop ((current (next-reduction rib)) (output 'WRAP-AROUND))
- (let ((step
- (if (dummy-compiler-reduction? current)
- '()
- (cons (list (reduction-expression current)
- (reduction-environment current))
- (if (marked-reduction? current)
- '()
- output)))))
- (if (eq? current rib)
- step
- (loop (next-reduction current) step)))))
-
-(define the-empty-history
- (cons (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'DUMMY-HISTORY))
- '()))
-
-(define (history-superproblem history)
- (if (null? (cdr history))
- history
- (force (cddr history))))
-
-(define (history-reductions history)
- (if (null? (cdr history))
- '()
- (force (cadr history))))
-
-(define (history-untransform history)
- (car history))
-
-;;; end HISTORY-PACKAGE.
-(the-environment)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 13.43 1987/03/17 18:50:41 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Input
-
-(declare (usual-integrations))
-\f
-;;;; Input Ports
-
-(define input-port-tag
- "Input Port")
-
-(define (input-port? object)
- (and (environment? object)
- (not (lexical-unreferenceable? object ':type))
- (eq? (access :type object) input-port-tag)))
-
-(define eof-object
- "EOF Object")
-
-(define (eof-object? object)
- (eq? object eof-object))
-
-(define *current-input-port*)
-
-(define (current-input-port)
- *current-input-port*)
-
-(define (with-input-from-port port thunk)
- (if (not (input-port? port)) (error "Bad input port" port))
- (fluid-let ((*current-input-port* port))
- (thunk)))
-
-(define (with-input-from-file input-specifier thunk)
- (define new-port (open-input-file input-specifier))
- (define old-port)
- (dynamic-wind (lambda ()
- (set! old-port
- (set! *current-input-port*
- (set! new-port))))
- thunk
- (lambda ()
- (let ((port))
- ;; Only SET! is guaranteed to do the right thing with
- ;; an unassigned value. Binding may not work right.
- (set! port (set! *current-input-port* (set! old-port)))
- (if (not (unassigned? port))
- (close-input-port port))))))
-
-(define (call-with-input-file input-specifier receiver)
- (let ((port (open-input-file input-specifier)))
- (let ((value (receiver port)))
- (close-input-port port)
- value)))
-
-(define (close-input-port port)
- ((access :close port)))
-\f
-;;;; Console Input Port
-
-(define console-input-port)
-(let ()
-
-(define tty-read-char
- (make-primitive-procedure 'TTY-READ-CHAR))
-
-(define tty-read-char-immediate
- (make-primitive-procedure 'TTY-READ-CHAR-IMMEDIATE))
-
-(define tty-read-char-ready?
- (make-primitive-procedure 'TTY-READ-CHAR-READY?))
-
-(define tty-read-finish
- (make-primitive-procedure 'TTY-READ-FINISH))
-
-(define (read-start-hook)
- 'DONE)
-
-(define (read-finish-hook)
- 'DONE)
-
-(set! console-input-port
- (make-environment
-
-(define :type input-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Console input port"))))
-
-(define (:close)
- 'DONE)
-
-(define character-buffer
- false)
-
-(define (:peek-char)
- (or character-buffer
- (begin (set! character-buffer (tty-read-char))
- character-buffer)))
-
-(define (:discard-char)
- (set! character-buffer false))
-\f
-(define (:read-char)
- (if character-buffer
- (set! character-buffer false)
- (tty-read-char)))
-
-(define (:read-string delimiters)
- (define (loop)
- (if (char-set-member? delimiters (:peek-char))
- '()
- (let ((char (:read-char)))
- (cons char (loop)))))
- (list->string (loop)))
-
-(define (:discard-chars delimiters)
- (define (loop)
- (if (not (char-set-member? delimiters (:peek-char)))
- (begin (:discard-char)
- (loop))))
- (loop))
-
-(define (:peek-char-immediate)
- (or character-buffer
- (begin (set! character-buffer (tty-read-char-immediate))
- character-buffer)))
-
-(define (:read-char-immediate)
- (if character-buffer
- (set! character-buffer false)
- (tty-read-char-immediate)))
-
-(define (:char-ready? delay)
- (or character-buffer (tty-read-char-ready? delay)))
-
-(define (:read-start!)
- (read-start-hook))
-
-(define :read-finish!
- (let ()
- (define (read-finish-loop)
- (if (and (:char-ready? 0)
- (char-whitespace? (:peek-char)))
- (begin (:discard-char)
- (read-finish-loop))))
- (lambda ()
- (tty-read-finish)
- (read-finish-loop)
- (read-finish-hook))))
-
-;;; end CONSOLE-INPUT-PORT.
-))
-
-)
-
-(set! *current-input-port* console-input-port)
-\f
-;;;; File Input Ports
-
-(define open-input-file)
-(let ()
-
-(define file-fill-input-buffer
- (make-primitive-procedure 'FILE-FILL-INPUT-BUFFER))
-
-(define file-length
- (make-primitive-procedure 'FILE-LENGTH))
-
-(define file-port-buffer-size
- 512)
-
-(set! open-input-file
-(named-lambda (open-input-file filename)
- (let ((file-channel ((access open-input-channel primitive-io)
- (canonicalize-input-filename filename))))
-
-(define :type input-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Buffered input port for file: ")
- (write ((access channel-name primitive-io) file-channel)))))
-
-(define (:pathname)
- (->pathname filename))
-
-(define (:truename)
- (->pathname ((access channel-name primitive-io) file-channel)))
-
-(define (:length)
- (file-length file-channel))
-\f
-(define buffer false)
-(define start-index 0)
-(define end-index -1)
-
-(define (refill-buffer!)
- (if (not buffer) (set! buffer (string-allocate file-port-buffer-size)))
- (set! start-index 0)
- (set! end-index (file-fill-input-buffer file-channel buffer))
- (zero? end-index))
-
-(define (:char-ready? delay)
- (not (zero? end-index)))
-
-(define (:close)
- (set! end-index 0)
- (set! buffer false)
- ((access close-physical-channel primitive-io) file-channel))
-
-(define (:peek-char)
- (if (< start-index end-index)
- (string-ref buffer start-index)
- (and (not (zero? end-index))
- (not (refill-buffer!))
- (string-ref buffer 0))))
-
-(define (:discard-char)
- (set! start-index (1+ start-index)))
-
-(define (:read-char)
- (if (< start-index end-index)
- (string-ref buffer (set! start-index (1+ start-index)))
- (and (not (zero? end-index))
- (not (refill-buffer!))
- (begin (set! start-index 1)
- (string-ref buffer 0)))))
-\f
-(define (:read-string delimiters)
- (define (loop)
- (let ((index
- (substring-find-next-char-in-set buffer start-index end-index
- delimiters)))
- (if index
- (substring buffer (set! start-index index) index)
- (let ((head (substring buffer start-index end-index)))
- (if (refill-buffer!)
- head
- (let ((tail (loop))
- (head-length (string-length head)))
- (let ((result (string-allocate (+ head-length
- (string-length tail)))))
- (substring-move-right! head 0 head-length
- result 0)
- (substring-move-right! tail 0 (string-length tail)
- result head-length)
- result)))))))
- (and (or (< start-index end-index)
- (and (not (zero? end-index))
- (not (refill-buffer!))))
- (loop)))
-
-(define (:discard-chars delimiters)
- (define (loop)
- (let ((index
- (substring-find-next-char-in-set buffer start-index end-index
- delimiters)))
- (cond (index (set! start-index index))
- ((not (refill-buffer!)) (loop)))))
- (if (or (< start-index end-index)
- (and (not (zero? end-index))
- (not (refill-buffer!))))
- (loop)))
-\f
-(define (:rest->string)
- (define (read-rest)
- (set! end-index 0)
- (loop))
-
- (define (loop)
- (let ((buffer (string-allocate file-port-buffer-size)))
- (let ((n (file-fill-input-buffer file-channel buffer)))
- (cond ((zero? n) '())
- ((< n file-port-buffer-size)
- (set-string-length! buffer n)
- (list buffer))
- (else (cons buffer (loop)))))))
-
- (if (zero? end-index)
- (error "End of file -- :REST->STRING"))
- (cond ((= -1 end-index)
- (let ((l (:length)))
- (if l
- (let ((buffer (string-allocate l)))
- (set! end-index 0)
- (file-fill-input-buffer file-channel buffer)
- buffer)
- (apply string-append (read-rest)))))
- ((< start-index end-index)
- (let ((first (substring buffer start-index end-index)))
- (apply string-append
- (cons first
- (read-rest)))))
- (else
- (apply string-append (read-rest)))))
-
-(the-environment))))
-
-)
-\f
-;;;; String Input Ports
-
-(define (with-input-from-string string thunk)
- (fluid-let ((*current-input-port* (string->input-port string)))
- (thunk)))
-
-(define (string->input-port string #!optional start end)
- (cond ((unassigned? start)
- (set! start 0)
- (set! end (string-length string)))
- ((unassigned? end)
- (set! end (string-length string))))
-
-(define :type input-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Input port for string"))))
-
-(define (:char-ready? delay)
- (< start end))
-
-(define (:close) 'DONE)
-
-(define (:peek-char)
- (and (< start end)
- (string-ref string start)))
-
-(define (:discard-char)
- (set! start (1+ start)))
-
-(define (:read-char)
- (and (< start end)
- (string-ref string (set! start (1+ start)))))
-
-(define (:read-string delimiters)
- (and (< start end)
- (let ((index
- (substring-find-next-char-in-set string start end delimiters)))
- (if index
- (substring string (set! start index) index)
- (substring string start end)))))
-
-(define (:discard-chars delimiters)
- (if (< start end)
- (set! start
- (or (substring-find-next-char-in-set string start end delimiters)
- end))))
-
-;;; end STRING->INPUT-PORT.
-(the-environment))
-\f
-;;;; Input Procedures
-
-(define (peek-char #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((if (lexical-unreferenceable? port ':peek-char-immediate)
- (access :peek-char port)
- (access :peek-char-immediate port)))
- eof-object))
-
-(define (read-char #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((if (lexical-unreferenceable? port ':read-char-immediate)
- (access :read-char port)
- (access :read-char-immediate port)))
- eof-object))
-
-(define (read-string delimiters #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (or ((access :read-string port) delimiters)
- eof-object))
-
-(define (read #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (if (not (lexical-unreferenceable? port ':read-start!))
- ((access :read-start! port)))
- (let ((object ((access *parse-object parser-package) port)))
- (if (not (lexical-unreferenceable? port ':read-finish!))
- ((access :read-finish! port)))
- object))
-
-;;; **** The DELAY option for this operation works only for the
-;;; console port. Since it is a kludge, it is probably OK.
-
-(define (char-ready? #!optional port delay)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (cond ((unassigned? delay) (set! delay 0))
- ((not (and (integer? delay) (>= delay 0))) (error "Bad delay" delay)))
- ((access :char-ready? port) delay))
-
-(define (read-char-no-hang #!optional port)
- (cond ((unassigned? port) (set! port *current-input-port*))
- ((not (input-port? port)) (error "Bad input port" port)))
- (and ((access :char-ready? port) 0)
- (read-char port)))
-\f
-(define load)
-(define load-noisily)
-(define load-noisily? false)
-(define read-file)
-(let ()
-
-(define default-pathname
- (make-pathname false false false false 'NEWEST))
-
-;;; This crufty piece of code, once it decides which file to load,
-;;; does `file-exists?' on that file at least three times!!
-
-(define (basic-load filename environment)
- (define (kernel filename)
- (let ((pathname
- (let ((pathname (->pathname filename)))
- (or (pathname->input-truename pathname)
- (let ((pathname (merge-pathnames pathname default-pathname)))
- (if (pathname-type pathname)
- (pathname->input-truename pathname)
- (or (pathname->input-truename
- (pathname-new-type pathname "bin"))
- (pathname->input-truename
- (pathname-new-type pathname "scm")))))
- (error "No such file" pathname)))))
- (if (call-with-input-file pathname
- (lambda (port)
- (= 250 (char->ascii (peek-char port)))))
- (scode-load pathname)
- (sexp-load pathname))))
-
- (define (sexp-load filename)
- (call-with-input-file filename
- (lambda (port)
- (define (load-loop previous-object)
- (let ((object (read port)))
- (if (eof-object? object)
- previous-object
- (let ((value (eval object environment)))
- (if load-noisily? (begin (newline) (write value)))
- (load-loop value)))))
- (load-loop *the-non-printing-object*))))
-
- (define (scode-load filename)
- (scode-eval (fasload filename) environment))
-
- (if (pair? filename)
- (for-each kernel filename)
- (kernel filename)))
-\f
-(set! load
-(named-lambda (load filename #!optional environment)
- (if (unassigned? environment) (set! environment (rep-environment)))
- (basic-load filename environment)))
-
-(set! load-noisily
-(named-lambda (load-noisily filename #!optional environment)
- (if (unassigned? environment) (set! environment (rep-environment)))
- (fluid-let ((load-noisily? true))
- (basic-load filename environment))))
-
-(set! read-file
-(named-lambda (read-file filename)
- (let ((name (pathname->input-truename
- (merge-pathnames (->pathname filename) default-pathname))))
- (if name
- (call-with-input-file name
- (access *parse-objects-until-eof parser-package))
- (error "Read-file: No such file" name)))))
-)
-\f
-(define fasload)
-(let ()
-
-(define binary-fasload
- (make-primitive-procedure 'BINARY-FASLOAD))
-
-(set! fasload
-(named-lambda (fasload filename)
- (set! filename (canonicalize-input-filename filename))
- (let ((port (rep-output-port)))
- (newline port)
- (write-string "FASLoading " port)
- (write filename port)
- (let ((value (binary-fasload filename)))
- (write-string " -- done" port)
- value))))
-
-)
-
-(define transcript-on
- (let ((photo-open (make-primitive-procedure 'PHOTO-OPEN)))
- (named-lambda (transcript-on filename)
- (if (not (photo-open (canonicalize-output-filename filename)))
- (error "Transcript file already open: TRANSCRIPT-ON" filename))
- *the-non-printing-object*)))
-
-(define transcript-off
- (let ((photo-close (make-primitive-procedure 'PHOTO-CLOSE)))
- (named-lambda (transcript-off)
- (if (not (photo-close))
- (error "Transcript file already closed: TRANSCRIPT-OFF"))
- *the-non-printing-object*)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 13.43 1987/03/17 18:50:56 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Interrupt System
-
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
-\f
-(define with-external-interrupts-handler)
-
-(define timer-interrupt
- (let ((setup-timer-interrupt
- (make-primitive-procedure 'SETUP-TIMER-INTERRUPT true)))
- (named-lambda (timer-interrupt)
- (setup-timer-interrupt '() '())
- (error "Unhandled Timer interrupt received"))))
-
-(define interrupt-system
- (let ((get-next-interrupt-character
- (make-primitive-procedure 'GET-NEXT-INTERRUPT-CHARACTER))
- (check-and-clean-up-input-channel
- (make-primitive-procedure 'CHECK-AND-CLEAN-UP-INPUT-CHANNEL))
- (index:interrupt-vector
- (fixed-objects-vector-slot 'SYSTEM-INTERRUPT-VECTOR))
- (index:termination-vector
- (fixed-objects-vector-slot
- 'MICROCODE-TERMINATIONS-PROCEDURES))
- (^Q-Hook '()))
-\f
-;;;; Soft interrupts
-
-;;; Timer interrupts
-
-(define (timer-interrupt-handler interrupt-code interrupt-enables)
- (timer-interrupt))
-
-;;; Keyboard Interrupts
-
-(define (external-interrupt-handler interrupt-code interrupt-enables)
- (let ((interrupt-character (get-next-interrupt-character)))
- ((vector-ref keyboard-interrupts interrupt-character) interrupt-character
- interrupt-enables)))
-
-(define (losing-keyboard-interrupt interrupt-character interrupt-enables)
- (error "Bad interrupt character" interrupt-character))
-
-(define keyboard-interrupts
- (vector-cons 256 losing-keyboard-interrupt))
-
-(define (install-keyboard-interrupt! interrupt-char handler)
- (vector-set! keyboard-interrupts
- (char->ascii interrupt-char)
- handler))
-
-(define (remove-keyboard-interrupt! interrupt-char)
- (vector-set! keyboard-interrupts
- (char->ascii interrupt-char)
- losing-keyboard-interrupt))
-
-(define until-most-recent-interrupt-character 0) ;for Pascal, ugh!
-(define multiple-copies-only 1)
-
-(define ((flush-typeahead kernel) interrupt-character interrupt-enables)
- (if (check-and-clean-up-input-channel until-most-recent-interrupt-character
- interrupt-character)
- (kernel interrupt-character interrupt-enables)))
-
-(define ((keep-typeahead kernel) interrupt-character interrupt-enables)
- (if (check-and-clean-up-input-channel multiple-copies-only
- interrupt-character)
- (kernel interrupt-character interrupt-enables)))
-\f
-(define ^B-interrupt-handler
- (keep-typeahead
- (lambda (interrupt-character interrupt-enables)
- (with-standard-proceed-point
- (lambda ()
- (breakpoint "^B interrupt" (rep-environment)))))))
-
-; (define ^S-interrupt-handler
-; (keep-typeahead
-; (lambda (interrupt-character interrupt-enables)
-; (if (null? ^Q-Hook)
-; (begin (set-interrupt-enables! interrupt-enables)
-; (beep)
-; (call-with-current-continuation
-; (lambda (stop-^S-wait)
-; (fluid-let ((^Q-Hook Stop-^S-Wait))
-; (let busy-wait () (busy-wait))))))))))
-;
-; (define ^Q-interrupt-handler
-; (keep-typeahead
-; (lambda (interrupt-character interrupt-enables)
-; (if (not (null? ^Q-Hook))
-; (begin (set-interrupt-enables! interrupt-enables)
-; (^Q-Hook 'GO-ON))))))
-;
-; (define ^P-interrupt-handler
-; (flush-typeahead
-; (lambda (interrupt-character interrupt-enables)
-; (set-interrupt-enables! interrupt-enables)
-; (proceed))))
-;
-; (define ^Z-interrupt-handler
-; (flush-typeahead
-; (lambda (interrupt-character interrupt-enables)
-; (set-interrupt-enables! interrupt-enables)
-; (edit))))
-
-(define ^G-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (abort-to-top-level-driver "Quit!"))))
-
-(define ^U-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (abort-to-previous-driver "Up!"))))
-
-(define ^X-interrupt-handler
- (flush-typeahead
- (lambda (interrupt-character interrupt-enables)
- (abort-to-nearest-driver "Abort!"))))
-
-(define (gc-out-of-space-handler . args)
- (abort-to-nearest-driver "Aborting! Out of memory"))
-\f
-(install-keyboard-interrupt! #\G ^G-interrupt-handler)
-(install-keyboard-interrupt! #\B ^B-interrupt-handler)
-; (install-keyboard-interrupt! #\P ^P-interrupt-handler)
-(install-keyboard-interrupt! #\U ^U-interrupt-handler)
-(install-keyboard-interrupt! #\X ^X-interrupt-handler)
-; (install-keyboard-interrupt! #\Z ^Z-interrupt-handler)
-; (install-keyboard-interrupt! #\S ^S-interrupt-handler)
-; (install-keyboard-interrupt! #\Q ^Q-interrupt-handler)
-
-(define stack-overflow-slot 0)
-(define gc-slot 2)
-(define character-slot 4)
-(define timer-slot 6)
-\f
-(define (install)
- (with-interrupts-reduced interrupt-mask-gc-ok
- (lambda (old-mask)
- (let ((old-system-interrupt-vector
- (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
- (old-termination-vector
- (vector-ref (get-fixed-objects-vector) index:termination-vector)))
- (let ((previous-gc-interrupt
- (vector-ref old-system-interrupt-vector gc-slot))
- (previous-stack-interrupt
- (vector-ref old-system-interrupt-vector stack-overflow-slot))
- (system-interrupt-vector
- (vector-cons (vector-length old-system-interrupt-vector)
- default-interrupt-handler))
- (termination-vector
- (if old-termination-vector
- (if (> number-of-microcode-terminations
- (vector-length old-termination-vector))
- (vector-grow old-termination-vector
- number-of-microcode-terminations)
- old-termination-vector)
- (vector-cons number-of-microcode-terminations false))))
-
- (vector-set! system-interrupt-vector gc-slot previous-gc-interrupt)
- (vector-set! system-interrupt-vector stack-overflow-slot
- previous-stack-interrupt)
- (vector-set! system-interrupt-vector character-slot
- external-interrupt-handler)
- (vector-set! system-interrupt-vector timer-slot
- timer-interrupt-handler)
-
- ;; slots 4-15 unused.
-
- ;; install the new vector atomically
- (vector-set! (get-fixed-objects-vector)
- index:interrupt-vector
- system-interrupt-vector)
-
- (vector-set! termination-vector
- (microcode-termination 'GC-OUT-OF-SPACE)
- gc-out-of-space-handler)
-
- (vector-set! (get-fixed-objects-vector)
- index:termination-vector
- termination-vector)
-
- (set-fixed-objects-vector! (get-fixed-objects-vector)))))))
-
-(define (default-interrupt-handler interrupt-code interrupt-enables)
- (write-string "Anomalous Interrupt: ") (write interrupt-code)
- (write-string " Mask: ") (write interrupt-enables))
-\f
-(set! with-external-interrupts-handler
-(named-lambda (with-external-interrupts-handler handler code)
- (define (interrupt-routine interrupt-code interrupt-enables)
- (let ((character (get-next-interrupt-character)))
- (check-and-clean-up-input-channel
- until-most-recent-interrupt-character
- character)
- (handler character interrupt-enables)))
-
- (define old-handler interrupt-routine)
-
- (define interrupt-vector
- (vector-ref (get-fixed-objects-vector) index:interrupt-vector))
-
- (dynamic-wind
- (lambda ()
- (set! old-handler
- (vector-set! interrupt-vector character-slot old-handler)))
- code
- (lambda ()
- (vector-set! interrupt-vector character-slot
- (set! old-handler
- (vector-ref interrupt-vector character-slot)))))))
-
-;;; end INTERRUPT-SYSTEM package.
-(the-environment)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 13.45 1987/04/13 18:43:17 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Input/output utilities
-
-(declare (usual-integrations))
-\f
-(define close-all-open-files)
-
-(define primitive-io
- (let ((open-file-list-tag '*ALL-THE-OPEN-FILES*)
-
- (weak-cons-type (microcode-type 'WEAK-CONS))
-
- (make-physical-channel (make-primitive-procedure 'HUNK3-CONS))
- (channel-descriptor system-hunk3-cxr0)
- (set-channel-descriptor! system-hunk3-set-cxr0!)
- (channel-name system-hunk3-cxr1)
- (channel-direction system-hunk3-cxr2)
- (set-channel-direction! system-hunk3-set-cxr2!)
-
- (closed-direction 0)
- (closed-descriptor false))
-
- (make-environment
-
-(declare (integrate-primitive-procedures
- (make-physical-channel hunk3-cons)
- (channel-descriptor system-hunk3-cxr0)
- (set-channel-descriptor! system-hunk3-set-cxr0!)
- (channel-name system-hunk3-cxr1)
- (channel-direction system-hunk3-cxr2)
- (set-channel-direction! system-hunk3-set-cxr2!)))
-
-(define open-files-list)
-(define traversing?)
-
-(define (initialize)
- (set! open-files-list (list open-file-list-tag))
- (set! traversing? false)
- true)
-\f
-;;;; Open/Close Files
-
-;;; Direction is one of the following:
-;;; - true: output channel
-;;; - false: input channel
-;;; - 0: closed channel
-
-(define open-channel-wrapper
- (let ((open-channel (make-primitive-procedure 'FILE-OPEN-CHANNEL)))
- (named-lambda ((open-channel-wrapper direction) filename)
- (without-interrupts
- (lambda ()
- (let ((channel
- (make-physical-channel (open-channel filename direction)
- filename
- direction)))
- (with-interrupt-mask interrupt-mask-none ; Disallow gc
- (lambda (ie)
- (set-cdr! open-files-list
- (cons (system-pair-cons weak-cons-type
- channel
- (channel-descriptor channel))
- (cdr open-files-list)))))
- channel))))))
-
-(define open-input-channel (open-channel-wrapper false))
-(define open-output-channel (open-channel-wrapper true))
-\f
-;; This is locked from interrupts, but GC can occur since the
-;; procedure itself hangs on to the channel until the last moment,
-;; when it returns the channel's name. The list will not be spliced
-;; by the daemon behind its back because of the traversing? flag.
-
-(define close-physical-channel
- (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
- (named-lambda (close-physical-channel channel)
- (fluid-let ((traversing? true))
- (without-interrupts
- (lambda ()
- (if (eq? closed-direction
- (set-channel-direction! channel closed-direction))
- true ;Already closed!
- (begin
- (primitive (set-channel-descriptor! channel
- closed-descriptor))
- (let loop
- ((l1 open-files-list)
- (l2 (cdr open-files-list)))
- (cond ((null? l2)
- (set! traversing? false)
- (error "CLOSE-PHYSICAL-CHANNEL: lost channel"
- channel))
- ((eq? channel (system-pair-car (car l2)))
- (set-cdr! l1 (cdr l2))
- (channel-name channel))
- (else
- (loop l2 (cdr l2)))))))))))))
-\f
-;;;; Finalization and daemon.
-
-(define (close-files action)
- (lambda ()
- (fluid-let ((traversing? true))
- (without-interrupts
- (lambda ()
- (let loop ((l (cdr open-files-list)))
- (cond ((null? l) true)
- (else
- (let ((channel (system-pair-car (car l))))
- (if (not (eq? channel false))
- (begin
- (set-channel-descriptor! channel
- closed-descriptor)
- (set-channel-direction! channel
- closed-direction)))
- (action (system-pair-cdr (car l)))
- (set-cdr! open-files-list (cdr l)))
- (loop (cdr open-files-list))))))))))
-
-;;; This is invoked before disk-restoring. It "cleans" the microcode.
-
-(set! close-all-open-files
- (close-files (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
-
-;;; This is invoked after disk-restoring. It "cleans" the new runtime system.
-
-(define reset!
- (close-files (lambda (ignore) true)))
-\f
-;; This is the daemon which closes files which no one points to.
-;; Runs with GC, and lower priority interrupts, disabled.
-;; It is unsafe because of the (unnecessary) consing by the
-;; interpreter while it executes the loop.
-
-;; Replaced by a primitive installed below.
-
-#|
-
-(define close-lost-open-files-daemon
- (let ((primitive (make-primitive-procedure 'FILE-CLOSE-CHANNEL)))
- (named-lambda (close-lost-open-files-daemon)
- (if (not traversing?)
- (let loop
- ((l1 open-files-list)
- (l2 (cdr open-files-list)))
- (cond ((null? l2)
- true)
- ((null? (system-pair-car (car l2)))
- (primitive (system-pair-cdr (car l2)))
- (set-cdr! l1 (cdr l2))
- (loop l1 (cdr l1)))
- (else
- (loop l2 (cdr l2)))))))))
-
-|#
-
-(define close-lost-open-files-daemon
- (let ((primitive (make-primitive-procedure 'CLOSE-LOST-OPEN-FILES)))
- (named-lambda (close-lost-open-files-daemon)
- (if (not traversing?)
- (primitive open-files-list)))))
-
-;;; End of PRIMITIVE-IO package.
-)))
-
-((access initialize primitive-io))
-(add-gc-daemon! (access close-lost-open-files-daemon primitive-io))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 13.42 1987/03/17 18:51:08 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Lambda Abstraction
-
-(declare (usual-integrations))
-\f
-(define lambda?)
-(define make-lambda)
-(define lambda-components)
-(define lambda-body)
-(define set-lambda-body!)
-(define lambda-bound)
-
-(define lambda-package
- (let ((slambda-type (microcode-type 'LAMBDA))
- (slexpr-type (microcode-type 'LEXPR))
- (xlambda-type (microcode-type 'EXTENDED-LAMBDA))
- (internal-lambda-tag (make-named-tag "INTERNAL-LAMBDA"))
- (internal-lexpr-tag (make-named-tag "INTERNAL-LEXPR"))
- (lambda-optional-tag (make-interned-symbol "#!OPTIONAL"))
- (lambda-rest-tag (make-interned-symbol "#!REST")))
-
-(define internal-lambda-tags
- (list internal-lambda-tag internal-lexpr-tag))
-\f
-;;;; Hairy Advice Wrappers
-
-;;; The body of a LAMBDA object can be modified by transformation.
-;;; This has the advantage that the body can be transformed many times,
-;;; but the original state will always remain.
-
-;;; **** Note: this stuff was implemented for the advice package.
-;;; Please don't use it for anything else since it will just
-;;; confuse things.
-
-(define lambda-body-procedures
- (let ((wrapper-tag '(LAMBDA-WRAPPER))
- (wrapper-body comment-expression)
- (set-wrapper-body! set-comment-expression!))
-
- (define (make-wrapper original-body new-body state)
- (make-comment (vector wrapper-tag original-body state)
- new-body))
-
- (define (wrapper? object)
- (and (comment? object)
- (let ((text (comment-text object)))
- (and (vector? text)
- (not (zero? (vector-length text)))
- (eq? (vector-ref text 0) wrapper-tag)))))
-
- (define (wrapper-state wrapper)
- (vector-ref (comment-text wrapper) 2))
-
- (define (set-wrapper-state! wrapper new-state)
- (vector-set! (comment-text wrapper) 2 new-state))
-
- (define (wrapper-original-body wrapper)
- (vector-ref (comment-text wrapper) 1))
-
- (define (set-wrapper-original-body! wrapper new-body)
- (vector-set! (comment-text wrapper) 1 new-body))
-\f
- (named-lambda (lambda-body-procedures physical-body set-physical-body!
- receiver)
- (receiver
-
- (named-lambda (wrap-body! lambda transform)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (transform (wrapper-body physical-body)
- (wrapper-state physical-body)
- (lambda (new-body new-state)
- (set-wrapper-body! physical-body new-body)
- (set-wrapper-state! physical-body new-state)))
- (transform physical-body
- '()
- (lambda (new-body new-state)
- (set-physical-body! lambda
- (make-wrapper physical-body
- new-body
- new-state)))))))
-
- (named-lambda (wrapper-components lambda receiver)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (receiver (wrapper-original-body physical-body)
- (wrapper-state physical-body))
- (receiver physical-body
- '()))))
-
- (named-lambda (unwrap-body! lambda)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (set-physical-body! lambda
- (wrapper-original-body physical-body)))))
-
- (named-lambda (unwrapped-body lambda)
- (let ((physical-body (physical-body lambda)))
- (if (wrapper? physical-body)
- (wrapper-original-body physical-body)
- physical-body)))
-
- (named-lambda (set-unwrapped-body! lambda new-body)
- (if (wrapper? (physical-body lambda))
- (set-wrapper-original-body! (physical-body lambda) new-body)
- (set-physical-body! lambda new-body)))
-
- ))
- ))
-\f
-;;;; Compound Lambda
-
-(define (make-clambda name required auxiliary body)
- (make-slambda name
- required
- (if (null? auxiliary)
- body
- (make-combination (make-slambda internal-lambda-tag
- auxiliary
- body)
- (map (lambda (auxiliary)
- (make-unassigned-object))
- auxiliary)))))
-
-(define (clambda-components clambda receiver)
- (slambda-components clambda
- (lambda (name required body)
- (let ((unwrapped-body (clambda-unwrapped-body clambda)))
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (is-internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- (receiver name required '() '() auxiliary
- unwrapped-body)))
- (receiver name required '() '() '() unwrapped-body)))
- (receiver name required '() '() '() unwrapped-body))))))
-
-(define (clambda-bound clambda)
- (slambda-components clambda
- (lambda (name required body)
- (if (combination? body)
- (let ((operator (combination-operator body)))
- (if (is-internal-lambda? operator)
- (slambda-components operator
- (lambda (tag auxiliary body)
- (append required auxiliary)))
- required))
- required))))
-
-(define (clambda-has-internal-lambda? clambda)
- (let ((body (slambda-body clambda)))
- (and (combination? body)
- (let ((operator (combination-operator body)))
- (and (is-internal-lambda? operator)
- operator)))))
-\f
-(define clambda-wrap-body!)
-(define clambda-wrapper-components)
-(define clambda-unwrap-body!)
-(define clambda-unwrapped-body)
-(define set-clambda-unwrapped-body!)
-
-(lambda-body-procedures (lambda (clambda)
- (slambda-body
- (or (clambda-has-internal-lambda? clambda)
- clambda)))
- (lambda (clambda new-body)
- (set-slambda-body!
- (or (clambda-has-internal-lambda? clambda)
- clambda)
- new-body))
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! clambda-wrap-body! wrap-body!)
- (set! clambda-wrapper-components wrapper-components)
- (set! clambda-unwrap-body! unwrap-body!)
- (set! clambda-unwrapped-body unwrapped-body)
- (set! set-clambda-unwrapped-body! set-unwrapped-body!)))
-\f
-;;;; Compound Lexpr
-
-(define (make-clexpr name required rest auxiliary body)
- (make-slexpr name
- required
- (make-combination (make-slambda internal-lexpr-tag
- (cons rest auxiliary)
- body)
- (cons (let ((e (make-the-environment)))
- (make-combination
- system-subvector-to-list
- (list e
- (+ (length required) 3)
- (make-combination
- system-vector-size
- (list e)))))
- (map (lambda (auxiliary)
- (make-unassigned-object))
- auxiliary)))))
-
-(define (clexpr-components clexpr receiver)
- (slexpr-components clexpr
- (lambda (name required body)
- (slambda-components (combination-operator body)
- (lambda (tag auxiliary body)
- (receiver name
- required
- '()
- (car auxiliary)
- (cdr auxiliary)
- (clexpr-unwrapped-body clexpr)))))))
-
-(define (clexpr-bound clexpr)
- (slexpr-components clexpr
- (lambda (name required body)
- (slambda-components (combination-operator body)
- (lambda (tag auxiliary body)
- (append required auxiliary))))))
-
-(define (clexpr-has-internal-lambda? clexpr)
- (combination-operator (slexpr-body clexpr)))
-\f
-(define clexpr-wrap-body!)
-(define clexpr-wrapper-components)
-(define clexpr-unwrap-body!)
-(define clexpr-unwrapped-body)
-(define set-clexpr-unwrapped-body!)
-
-(lambda-body-procedures (lambda (clexpr)
- (slambda-body (clexpr-has-internal-lambda? clexpr)))
- (lambda (clexpr new-body)
- (set-slambda-body!
- (clexpr-has-internal-lambda? clexpr)
- new-body))
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! clexpr-wrap-body! wrap-body!)
- (set! clexpr-wrapper-components wrapper-components)
- (set! clexpr-unwrap-body! unwrap-body!)
- (set! clexpr-unwrapped-body unwrapped-body)
- (set! set-clexpr-unwrapped-body! set-unwrapped-body!)))
-\f
-;;;; Extended Lambda
-
-(define (make-xlambda name required optional rest auxiliary body)
- (&typed-triple-cons xlambda-type
- body
- (list->vector
- `(,name ,@required
- ,@optional
- ,@(if (null? rest)
- auxiliary
- (cons rest auxiliary))))
- (make-non-pointer-object
- (+ (length optional)
- (* 256
- (+ (length required)
- (if (null? rest) 0 256)))))))
-
-(define (xlambda-components xlambda receiver)
- (let ((qr1 (integer-divide (primitive-datum (&triple-third xlambda)) 256)))
- (let ((qr2 (integer-divide (car qr1) 256)))
- (let ((ostart (1+ (cdr qr2))))
- (let ((rstart (+ ostart (cdr qr1))))
- (let ((astart (+ rstart (car qr2)))
- (bound (&triple-second xlambda)))
- (receiver (vector-ref bound 0)
- (subvector->list bound 1 ostart)
- (subvector->list bound ostart rstart)
- (if (zero? (car qr2))
- '()
- (vector-ref bound rstart))
- (subvector->list bound
- astart
- (vector-length bound))
- (xlambda-unwrapped-body xlambda))))))))
-
-(define (xlambda-bound xlambda)
- (let ((names (&triple-second xlambda)))
- (subvector->list names 1 (vector-length names))))
-
-(define (xlambda-has-internal-lambda? xlambda)
- false)
-\f
-(define xlambda-wrap-body!)
-(define xlambda-wrapper-components)
-(define xlambda-unwrap-body!)
-(define xlambda-unwrapped-body)
-(define set-xlambda-unwrapped-body!)
-
-(lambda-body-procedures &triple-first &triple-set-first!
- (lambda (wrap-body! wrapper-components unwrap-body!
- unwrapped-body set-unwrapped-body!)
- (set! xlambda-wrap-body! wrap-body!)
- (set! xlambda-wrapper-components wrapper-components)
- (set! xlambda-unwrap-body! unwrap-body!)
- (set! xlambda-unwrapped-body unwrapped-body)
- (set! set-xlambda-unwrapped-body! set-unwrapped-body!)))
-\f
-;;;; Generic Lambda
-
-(set! lambda?
-(named-lambda (lambda? object)
- (or (primitive-type? slambda-type object)
- (primitive-type? slexpr-type object)
- (primitive-type? xlambda-type object))))
-
-(define (is-internal-lambda? lambda)
- (and (primitive-type? slambda-type lambda)
- (memq (slambda-name lambda) internal-lambda-tags)))
-
-(set! make-lambda
-(named-lambda (make-lambda name required optional rest auxiliary
- declarations body)
- (let ((body* (if (null? declarations)
- body
- (make-sequence (list (make-block-declaration declarations)
- body)))))
- (cond ((and (< (length required) 256)
- (< (length optional) 256)
- (or (not (null? optional))
- (not (null? rest))
- (not (null? auxiliary))))
- (make-xlambda name required optional rest auxiliary body*))
- ((not (null? optional))
- (error "Optionals not implemented" 'MAKE-LAMBDA))
- ((null? rest)
- (make-clambda name required auxiliary body*))
- (else
- (make-clexpr name required rest auxiliary body*))))))
-
-(set! lambda-components
-(named-lambda (lambda-components lambda receiver)
- (&lambda-components lambda
- (lambda (name required optional rest auxiliary body)
- (let ((actions (and (sequence? body)
- (sequence-actions body))))
- (if (and actions
- (block-declaration? (car actions)))
- (receiver name required optional rest auxiliary
- (block-declaration-text (car actions))
- (make-sequence (cdr actions)))
- (receiver name required optional rest auxiliary '() body)))))))
-
-(define ((dispatch-0 op-name clambda-op clexpr-op xlambda-op) lambda)
- ((cond ((primitive-type? slambda-type lambda) clambda-op)
- ((primitive-type? slexpr-type lambda) clexpr-op)
- ((primitive-type? xlambda-type lambda) xlambda-op)
- (else (error "Not a lambda" op-name lambda)))
- lambda))
-\f
-(define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) lambda arg)
- ((cond ((primitive-type? slambda-type lambda) clambda-op)
- ((primitive-type? slexpr-type lambda) clexpr-op)
- ((primitive-type? xlambda-type lambda) xlambda-op)
- (else (error "Not a lambda" op-name lambda)))
- lambda arg))
-
-(define &lambda-components
- (dispatch-1 'LAMBDA-COMPONENTS
- clambda-components
- clexpr-components
- xlambda-components))
-
-(define has-internal-lambda?
- (dispatch-0 'HAS-INTERNAL-LAMBDA?
- clambda-has-internal-lambda?
- clexpr-has-internal-lambda?
- xlambda-has-internal-lambda?))
-
-(define lambda-wrap-body!
- (dispatch-1 'LAMBDA-WRAP-BODY!
- clambda-wrap-body!
- clexpr-wrap-body!
- xlambda-wrap-body!))
-
-(define lambda-wrapper-components
- (dispatch-1 'LAMBDA-WRAPPER-COMPONENTS
- clambda-wrapper-components
- clexpr-wrapper-components
- xlambda-wrapper-components))
-
-(define lambda-unwrap-body!
- (dispatch-0 'LAMBDA-UNWRAP-BODY!
- clambda-unwrap-body!
- clexpr-unwrap-body!
- xlambda-unwrap-body!))
-
-(set! lambda-body
- (dispatch-0 'LAMBDA-BODY
- clambda-unwrapped-body
- clexpr-unwrapped-body
- xlambda-unwrapped-body))
-
-(set! set-lambda-body!
- (dispatch-1 'SET-LAMBDA-BODY!
- set-clambda-unwrapped-body!
- set-clexpr-unwrapped-body!
- set-xlambda-unwrapped-body!))
-
-(set! lambda-bound
- (dispatch-0 'LAMBDA-BOUND
- clambda-bound
- clexpr-bound
- xlambda-bound))
-\f
-;;;; Simple Lambda/Lexpr
-
-(define (make-slambda name required body)
- (&typed-pair-cons slambda-type body (list->vector (cons name required))))
-
-(define (slambda-components slambda receiver)
- (let ((bound (&pair-cdr slambda)))
- (receiver (vector-ref bound 0)
- (subvector->list bound 1 (vector-length bound))
- (&pair-car slambda))))
-
-(define (slambda-name slambda)
- (vector-ref (&pair-cdr slambda) 0))
-
-(define slambda-body &pair-car)
-(define set-slambda-body! &pair-set-car!)
-
-(define (make-slexpr name required body)
- (&typed-pair-cons slexpr-type body (list->vector (cons name required))))
-
-(define slexpr-components slambda-components)
-(define slexpr-body slambda-body)
-
-;;; end LAMBDA-PACKAGE.
-(the-environment)))
-\f
-;;;; Alternative Component Views
-
-(define (make-lambda* name required optional rest body)
- (scan-defines body
- (lambda (auxiliary declarations body*)
- (make-lambda name required optional rest auxiliary declarations body*))))
-
-(define (lambda-components* lambda receiver)
- (lambda-components lambda
- (lambda (name required optional rest auxiliary declarations body)
- (receiver name required optional rest
- (make-open-block auxiliary declarations body)))))
-
-(define (lambda-components** lambda receiver)
- (lambda-components* lambda
- (lambda (name required optional rest body)
- (receiver (vector name required optional rest)
- (append required optional (if (null? rest) '() (list rest)))
- body))))
-
-(define (lambda-pattern/name pattern)
- (vector-ref pattern 0))
-
-(define (lambda-pattern/required pattern)
- (vector-ref pattern 1))
-
-(define (lambda-pattern/optional pattern)
- (vector-ref pattern 2))
-
-(define (lambda-pattern/rest pattern)
- (vector-ref pattern 3))
-
-(define (make-lambda** pattern bound body)
-
- (define (split pattern bound receiver)
- (cond ((null? pattern)
- (receiver '() bound))
- (else
- (split (cdr pattern) (cdr bound)
- (lambda (copy tail)
- (receiver (cons (car bound) copy)
- tail))))))
-
- (split (lambda-pattern/required pattern) bound
- (lambda (required tail)
- (split (lambda-pattern/optional pattern) tail
- (lambda (optional rest)
- (make-lambda* (lambda-pattern/name pattern)
- required
- optional
- (if (null? rest) rest (car rest))
- body))))))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/list.scm,v 13.42 1987/02/11 02:22:09 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; List Operations
-
-(declare (usual-integrations))
-\f
-;;; This IN-PACKAGE is just a kludge to prevent the definitions of the
-;;; primitives from shadowing the USUAL-INTEGRATIONS declaration.
-#| Temporarily relocated to `boot.scm' to help compiler.
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- cons pair? null? length car cdr set-car! set-cdr!
- general-car-cdr memq assq)))|#
-
-(define (list . elements)
- elements)
-
-(define (list? frob)
- (cond ((null? frob) true)
- ((pair? frob) (list? (cdr frob)))
- (else false)))
-
-(define (cons* first-element . rest-elements)
- (define (loop this-element rest-elements)
- (if (null? rest-elements)
- this-element
- (cons this-element
- (loop (car rest-elements)
- (cdr rest-elements)))))
- (loop first-element rest-elements))
-
-(define (make-list size #!optional value)
- (subvector->list (vector-cons size (if (unassigned? value) '() value))
- 0
- size))
-
-(define (list-copy elements)
- (apply list elements))
-
-(define (list-ref l n)
- (cond ((not (pair? l)) (error "LIST-REF: Bad argument" l n))
- ((zero? n) (car l))
- (else (list-ref (cdr l) (-1+ n)))))
-
-(define (list-tail l n)
- (cond ((zero? n) l)
- ((pair? l) (list-tail (cdr l) (-1+ n)))
- (else (error "LIST-TAIL: Bad argument" l))))
-
-(define the-empty-stream '())
-(define empty-stream? null?)
-(define head car)
-
-(define (tail stream)
- (force (cdr stream)))
-\f
-;;;; Standard Selectors
-
-(define (cddr x) (general-car-cdr x #o4))
-(define (cdar x) (general-car-cdr x #o5))
-(define (cadr x) (general-car-cdr x #o6))
-(define (caar x) (general-car-cdr x #o7))
-
-(define (cdddr x) (general-car-cdr x #o10))
-(define (cddar x) (general-car-cdr x #o11))
-(define (cdadr x) (general-car-cdr x #o12))
-(define (cdaar x) (general-car-cdr x #o13))
-(define (caddr x) (general-car-cdr x #o14))
-(define (cadar x) (general-car-cdr x #o15))
-(define (caadr x) (general-car-cdr x #o16))
-(define (caaar x) (general-car-cdr x #o17))
-
-(define (cddddr x) (general-car-cdr x #o20))
-(define (cdddar x) (general-car-cdr x #o21))
-(define (cddadr x) (general-car-cdr x #o22))
-(define (cddaar x) (general-car-cdr x #o23))
-(define (cdaddr x) (general-car-cdr x #o24))
-(define (cdadar x) (general-car-cdr x #o25))
-(define (cdaadr x) (general-car-cdr x #o26))
-(define (cdaaar x) (general-car-cdr x #o27))
-(define (cadddr x) (general-car-cdr x #o30))
-(define (caddar x) (general-car-cdr x #o31))
-(define (cadadr x) (general-car-cdr x #o32))
-(define (cadaar x) (general-car-cdr x #o33))
-(define (caaddr x) (general-car-cdr x #o34))
-(define (caadar x) (general-car-cdr x #o35))
-(define (caaadr x) (general-car-cdr x #o36))
-(define (caaaar x) (general-car-cdr x #o37))
-
-(define first car)
-(define (second x) (general-car-cdr x #o6))
-(define (third x) (general-car-cdr x #o14))
-(define (fourth x) (general-car-cdr x #o30))
-(define (fifth x) (general-car-cdr x #o60))
-(define (sixth x) (general-car-cdr x #o140))
-(define (seventh x) (general-car-cdr x #o300))
-(define (eighth x) (general-car-cdr x #o600))
-\f
-;;;; Sequence Operations
-
-(define (append . lists)
- (define (outer current remaining)
- (define (inner list)
- (cond ((pair? list) (cons (car list) (inner (cdr list))))
- ((null? list) (outer (car remaining) (cdr remaining)))
- (else (error "APPEND: Argument not a list" current))))
- (if (null? remaining)
- current
- (inner current)))
- (if (null? lists)
- '()
- (outer (car lists) (cdr lists))))
-
-(define (append! . lists)
- (define (loop head tail)
- (cond ((null? tail) head)
- ((null? head) (loop (car tail) (cdr tail)))
- ((pair? head)
- (set-cdr! (last-pair head) (loop (car tail) (cdr tail)))
- head)
- (else (error "APPEND!: Argument not a list" head))))
- (if (null? lists)
- '()
- (loop (car lists) (cdr lists))))
-
-(define (reverse l)
- (define (loop rest so-far)
- (cond ((pair? rest) (loop (cdr rest) (cons (car rest) so-far)))
- ((null? rest) so-far)
- (else (error "REVERSE: Argument not a list" l))))
- (loop l '()))
-
-(define (reverse! l)
- (define (loop current new-cdr)
- (cond ((pair? current) (loop (set-cdr! current new-cdr) current))
- ((null? current) new-cdr)
- (else (error "REVERSE!: Argument not a list" l))))
- (loop l '()))
-\f
-;;;; Mapping Procedures
-
-(define (map f . lists)
- (cond ((null? lists)
- (error "MAP: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (if (null? list)
- '()
- (cons (f (car list))
- (1-loop (cdr list))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (cons (apply f cars)
- (n-loop cdrs)))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- '())
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "MAP: Argument not a list" (car lists)))))))))
-\f
-(define (map* initial-value f . lists)
- (cond ((null? lists)
- (error "MAP*: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (if (null? list)
- initial-value
- (cons (f (car list))
- (1-loop (cdr list))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (cons (apply f cars)
- (n-loop cdrs)))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- initial-value)
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "MAP*: Argument not a list" (car lists)))))))))
-\f
-(define (for-each f . lists)
- (cond ((null? lists)
- (error "FOR-EACH: Too few arguments" f))
- ((null? (cdr lists))
- (let 1-loop ((list (car lists)))
- (if (null? list)
- *the-non-printing-object*
- (begin (f (car list))
- (1-loop (cdr list))))))
- (else
- (let n-loop ((lists lists))
- (let parse-cars
- ((lists lists)
- (receiver
- (lambda (cars cdrs)
- (apply f cars)
- (n-loop cdrs))))
- (cond ((null? lists)
- (receiver '() '()))
- ((null? (car lists))
- *the-non-printing-object*)
- ((pair? (car lists))
- (parse-cars (cdr lists)
- (lambda (cars cdrs)
- (receiver (cons (car (car lists)) cars)
- (cons (cdr (car lists)) cdrs)))))
- (else
- (error "FOR-EACH: Argument not a list" (car lists)))))))))
-
-(define mapcar map)
-(define mapcar* map*)
-(define mapc for-each)
-
-(define (there-exists? predicate)
- (define (loop objects)
- (and (pair? objects)
- (or (predicate (car objects))
- (loop (cdr objects)))))
- loop)
-
-(define (for-all? predicate)
- (define (loop objects)
- (if (pair? objects)
- (and (predicate (car objects))
- (loop (cdr objects)))
- true))
- loop)
-\f
-;;;; Generalized List Operations
-
-(define (positive-list-searcher predicate if-win if-lose)
- (define (list-searcher-loop list)
- (if (pair? list)
- (if (predicate list)
- (if-win list)
- (list-searcher-loop (cdr list)))
- (and if-lose (if-lose))))
- list-searcher-loop)
-
-(define (negative-list-searcher predicate if-win if-lose)
- (define (list-searcher-loop list)
- (if (pair? list)
- (if (predicate list)
- (list-searcher-loop (cdr list))
- (if-win list))
- (and if-lose (if-lose))))
- list-searcher-loop)
-
-(define (positive-list-transformer predicate tail)
- (define (list-transform-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (cons (car list)
- (list-transform-loop (cdr list)))
- (list-transform-loop (cdr list)))
- tail))
- list-transform-loop)
-
-(define (negative-list-transformer predicate tail)
- (define (list-transform-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-transform-loop (cdr list))
- (cons (car list)
- (list-transform-loop (cdr list))))
- tail))
- list-transform-loop)
-\f
-(define (list-deletor predicate)
- (define (list-deletor-loop list)
- (if (pair? list)
- (if (predicate (car list))
- (list-deletor-loop (cdr list))
- (cons (car list) (list-deletor-loop (cdr list))))
- '()))
- list-deletor-loop)
-
-(define (list-deletor! predicate)
- (define (trim-initial-segment list)
- (if (pair? list)
- (if (predicate (car list))
- (trim-initial-segment (cdr list))
- (begin (locate-initial-segment list (cdr list))
- list))
- list))
- (define (locate-initial-segment last this)
- (if (pair? this)
- (if (predicate (car this))
- (set-cdr! last (trim-initial-segment (cdr this)))
- (locate-initial-segment this (cdr this)))
- this))
- trim-initial-segment)
-
-(define (list-transform-positive list predicate)
- (let loop ((list list))
- (if (pair? list)
- (if (predicate (car list))
- (cons (car list) (loop (cdr list)))
- (loop (cdr list)))
- '())))
-
-(define (list-transform-negative list predicate)
- (let loop ((list list))
- (if (pair? list)
- (if (predicate (car list))
- (loop (cdr list))
- (cons (car list) (loop (cdr list))))
- '())))
-
-(define (list-search-positive list predicate)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list))
- (car list)
- (loop (cdr list))))))
-
-(define (list-search-negative list predicate)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list))
- (loop (cdr list))
- (car list)))))
-\f
-;;;; Membership Lists
-
-(define (member-procedure predicate)
- (lambda (element list)
- (let loop ((list list))
- (and (pair? list)
- (if (predicate (car list) element)
- list
- (loop (cdr list)))))))
-
-;(define memq (member-procedure eq?))
-(define memv (member-procedure eqv?))
-(define member (member-procedure equal?))
-
-(define (delete-member-procedure deletor predicate)
- (lambda (element list)
- ((deletor (lambda (match)
- (predicate match element)))
- list)))
-
-(define delq (delete-member-procedure list-deletor eq?))
-(define delv (delete-member-procedure list-deletor eqv?))
-(define delete (delete-member-procedure list-deletor equal?))
-
-(define delq! (delete-member-procedure list-deletor! eq?))
-(define delv! (delete-member-procedure list-deletor! eqv?))
-(define delete! (delete-member-procedure list-deletor! equal?))
-
-;;;; Association Lists
-
-(define (association-procedure predicate selector)
- (lambda (key alist)
- (let loop ((alist alist))
- (and (pair? alist)
- (if (predicate (selector (car alist)) key)
- (car alist)
- (loop (cdr alist)))))))
-
-;(define assq (association-procedure eq? car))
-(define assv (association-procedure eqv? car))
-(define assoc (association-procedure equal? car))
-
-(define ((delete-association-procedure deletor predicate selector) key alist)
- ((deletor (lambda (association)
- (predicate (selector association) key)))
- alist))
-
-(define del-assq (delete-association-procedure list-deletor eq? car))
-(define del-assv (delete-association-procedure list-deletor eqv? car))
-(define del-assoc (delete-association-procedure list-deletor equal? car))
-
-(define del-assq! (delete-association-procedure list-deletor! eq? car))
-(define del-assv! (delete-association-procedure list-deletor! eqv? car))
-(define del-assoc! (delete-association-procedure list-deletor! equal? car))
-\f
-;;;; Lastness
-
-(define (last-pair l)
- (if (pair? l)
- (let loop ((l l))
- (if (pair? (cdr l))
- (loop (cdr l))
- l))
- (error "LAST-PAIR: Argument not a list" l)))
-
-(define (except-last-pair l)
- (if (pair? l)
- (let loop ((l l))
- (if (pair? (cdr l))
- (cons (car l)
- (loop (cdr l)))
- '()))
- (error "EXCEPT-LAST-PAIR: Argument not a list" l)))
-
-(define (except-last-pair! l)
- (if (pair? l)
- (if (pair? (cdr l))
- (begin (let loop ((l l))
- (if (pair? (cddr l))
- (loop (cdr l))
- (set-cdr! l '())))
- l)
- '())
- (error "EXCEPT-LAST-PAIR!: Argument not a list" l)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/msort.scm,v 13.41 1987/01/23 00:15:59 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Merge Sort
-
-(declare (usual-integrations))
-\f
-;; Functional and unstable but fairly fast
-
-(define (sort the-list p)
- (define (loop l)
- (if (and (pair? l) (pair? (cdr l)))
- (split l '() '())
- l))
-
- (define (split l one two)
- (if (pair? l)
- (split (cdr l) two (cons (car l) one))
- (merge (loop one) (loop two))))
-
- (define (merge one two)
- (cond ((null? one) two)
- ((p (car two) (car one))
- (cons (car two)
- (merge (cdr two) one)))
- (else
- (cons (car one)
- (merge (cdr one) two)))))
-
- (loop the-list))
-
-;; In-place and stable, fairly slow
-
-#|
-
-(define (sort! vector p)
- (define (merge! source target low1 high1 low2 high2 point)
- (define (loop low1 high1 low2 high2 point)
- (cond ((= low1 high1) (transfer! source target low2 high2 point))
- ((p (vector-ref source low2) (vector-ref source low1))
- (vector-set! target point (vector-ref source low2))
- (loop (1+ low2) high2 low1 high1 (1+ point)))
- (else
- (vector-set! target point (vector-ref source low1))
- (loop (1+ low1) high1 low2 high2 (1+ point)))))
- (loop low1 high1 low2 high2 point))
- (define (transfer! from to low high where)
- (if (= low high)
- 'DONE
- (begin (vector-set! to where (vector-ref from low))
- (transfer! from to (1+ low) high (1+ where)))))
- (define (split! source target low high)
- (let ((bound (ceiling (/ (+ low high) 2))))
- (transfer! source target low bound low)
- (transfer! source target bound high bound)
- (do! target source low bound)
- (do! target source bound high)
- (merge! target source low bound bound high low)))
- (define (do! source target low high)
- (if (< high (+ low 2))
- 'DONE
- (split! source target low high)))
- (let ((size (vector-length vector)))
- (do! vector (vector-cons size '()) 0 size)
- vector))
-|#
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 13.42 1987/02/09 23:10:13 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Number Parser
-
-(declare (usual-integrations))
-\f
-(define string->number)
-
-(define number-parser-package
- (make-environment
-
-;;; These are not supported right now.
-
-(define ->exact identity-procedure)
-(define ->inexact identity-procedure)
-(define ->long-flonum identity-procedure)
-(define ->short-flonum identity-procedure)
-
-(define *radix*)
-
-(set! string->number
-(named-lambda (string->number string #!optional exactness radix)
- ((cond ((or (unassigned? exactness) (not exactness)) identity-procedure)
- ((eq? exactness 'E) ->exact)
- ((eq? exactness 'I) ->inexact)
- (else (error "Illegal exactness argument" exactness)))
- (fluid-let ((*radix*
- (cond ((unassigned? radix) *parser-radix*)
- ((memv radix '(2 8 10 16)) radix)
- ((eq? radix 'B) 2)
- ((eq? radix 'O) 8)
- ((eq? radix 'D) 10)
- ((eq? radix 'X) 16)
- (else (error "Illegal radix argument" radix)))))
- (parse-number (string->list string))))))
-
-(define (parse-number chars)
- (parse-real chars
- (lambda (chars real)
- (if (null? chars)
- real
- (case (car chars)
- ((#\+ #\-)
- (parse-real chars
- (lambda (chars* real*)
- (and (not (null? chars*))
- (null? (cdr chars*))
- (or (char-ci=? (car chars*) #\i)
- (char-ci=? (car chars*) #\j))
- (make-rectangular real real*)))))
- ((#\@)
- (parse-real (cdr chars)
- (lambda (chars real*)
- (and (null? chars)
- (make-polar real real*)))))
- (else false))))))
-\f
-(define (parse-real chars receiver)
- (and (not (null? chars))
- (case (car chars)
- ((#\+)
- (parse-unsigned-real (cdr chars)
- receiver))
- ((#\-)
- (parse-unsigned-real (cdr chars)
- (lambda (chars real)
- (receiver chars (- real)))))
- (else
- (parse-unsigned-real chars
- receiver)))))
-
-(define (parse-unsigned-real chars receiver)
- (parse-prefix chars false false false
- (lambda (chars radix exactness precision)
- (define (finish)
- (parse-body chars
- (lambda (chars real)
- (parse-suffix chars
- (lambda (chars exponent)
- (receiver chars
- ((case exactness
- ((#F) identity-procedure)
- ((#\e) ->exact)
- ((#\i) ->inexact))
- ((case precision
- ((#F) identity-procedure)
- ((#\s) ->short-flonum)
- ((#\l) ->long-flonum))
- (if exponent
- (* real (expt 10 exponent))
- real)))))))))
- (if radix
- (fluid-let ((*radix*
- (cdr (assv radix
- '((#\b . 2)
- (#\o . 8)
- (#\d . 10)
- (#\x . 16))))))
- (finish))
- (finish)))))
-\f
-(define (parse-prefix chars radix exactness precision receiver)
- (and (not (null? chars))
- (if (char=? (car chars) #\#)
- (and (pair? (cdr chars))
- (let ((type (char-downcase (cadr chars)))
- (rest (cddr chars)))
- (let ((specify-prefix-type
- (lambda (old)
- (if old
- (error "Respecification of prefix type" type)
- type))))
- (case type
- ((#\b #\o #\d #\x)
- (parse-prefix rest
- (specify-prefix-type radix)
- exactness
- precision
- receiver))
- ((#\i #\e)
- (parse-prefix rest
- radix
- (specify-prefix-type exactness)
- precision
- receiver))
- ((#\s #\l)
- (parse-prefix rest
- radix
- exactness
- (specify-prefix-type precision)
- receiver))
- (else (error "Unknown prefix type" type))))))
- (receiver chars radix exactness precision))))
-\f
-(define (parse-suffix chars receiver)
- (if (and (not (null? chars))
- (char-ci=? (car chars) #\e))
- (parse-signed-suffix (cdr chars) receiver)
- (receiver chars false)))
-
-(define (parse-signed-suffix chars receiver)
- (and (not (null? chars))
- (case (car chars)
- ((#\+)
- (parse-unsigned-suffix (cdr chars)
- receiver))
- ((#\-)
- (parse-unsigned-suffix (cdr chars)
- (lambda (chars exponent)
- (receiver chars (- exponent)))))
- (else
- (parse-unsigned-suffix chars
- receiver)))))
-
-(define (parse-unsigned-suffix chars receiver)
- (define (parse-digit chars value if-digit)
- (let ((digit (char->digit (car chars) 10)))
- (if digit
- (if-digit (cdr chars) digit)
- (receiver chars value))))
-
- (define (loop chars value)
- (if (null? chars)
- (receiver chars value)
- (parse-digit chars value
- (lambda (chars digit)
- (loop chars (+ digit (* value 10)))))))
-
- (and (not (null? chars))
- (parse-digit chars false
- loop)))
-\f
-(define (parse-body chars receiver)
- (and (not (null? chars))
- (if (char=? (car chars) #\.)
- (require-digit (cdr chars)
- (lambda (chars digit)
- (parse-fraction chars digit 1
- receiver)))
- (parse-integer chars
- (lambda (chars integer)
- (if (null? chars)
- (receiver chars integer)
- (case (car chars)
- ((#\/)
- (parse-integer (cdr chars)
- (lambda (chars denominator)
- (receiver chars (/ integer denominator)))))
- ((#\.)
- (parse-fraction (cdr chars) 0 0
- (lambda (chars fraction)
- (receiver chars (+ integer fraction)))))
- (else
- (receiver chars integer)))))))))
-
-(define (parse-integer chars receiver)
- (define (loop chars integer)
- (parse-digit/sharp chars
- (lambda (chars count)
- (receiver chars (->inexact (* integer (expt *radix* count)))))
- (lambda (chars digit)
- (loop chars (+ digit (* integer *radix*))))
- (lambda (chars)
- (receiver chars integer))))
- (require-digit chars loop))
-
-(define (parse-fraction chars integer place-value receiver)
- (define (loop chars integer place-value)
- (parse-digit/sharp chars
- (lambda (chars count)
- (finish chars (->inexact integer) place-value))
- (lambda (chars digit)
- (loop chars
- (+ digit (* integer *radix*))
- (1+ place-value)))
- (lambda (chars)
- (finish chars integer place-value))))
-
- (define (finish chars integer place-value)
- (receiver chars (/ integer (expt *radix* place-value))))
-
- (loop chars integer place-value))
-\f
-(define (require-digit chars receiver)
- (and (not (null? chars))
- (let ((digit (char->digit (car chars) *radix*)))
- (and digit
- (receiver (cdr chars) digit)))))
-
-(define (parse-digit/sharp chars if-sharp if-digit otherwise)
- (cond ((null? chars) (otherwise chars))
- ((char=? (car chars) #\#)
- (let count-sharps ((chars (cdr chars)) (count 1))
- (if (and (not (null? chars))
- (char=? (car chars) #\#))
- (count-sharps (cdr chars) (1+ count))
- (if-sharp chars count))))
- (else
- (let ((digit (char->digit (car chars) *radix*)))
- (if digit
- (if-digit (cdr chars) digit)
- (otherwise chars))))))
-
-;;; end NUMBER-PARSER-PACKAGE
-))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 13.42 1987/02/15 15:45:07 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Output
-
-(declare (usual-integrations))
-\f
-;;;; Output Ports
-
-(define output-port-tag
- "Output Port")
-
-(define (output-port? object)
- (and (environment? object)
- (not (lexical-unreferenceable? object ':TYPE))
- (eq? (access :type object) output-port-tag)))
-
-(define *current-output-port*)
-
-(define (current-output-port)
- *current-output-port*)
-
-(define (with-output-to-port port thunk)
- (if (not (output-port? port)) (error "Bad output port" port))
- (fluid-let ((*current-output-port* port))
- (thunk)))
-
-(define (with-output-to-file output-specifier thunk)
- (define new-port (open-output-file output-specifier))
- (define old-port)
- (dynamic-wind (lambda ()
- (set! old-port
- (set! *current-output-port*
- (set! new-port))))
- thunk
- (lambda ()
- (let ((port))
- ;; Only SET! is guaranteed to do the right thing with
- ;; an unassigned value. Binding may not work right.
- (set! port (set! *current-output-port* (set! old-port)))
- (if (not (unassigned? port))
- (close-output-port port))))))
-
-(define (call-with-output-file output-specifier receiver)
- (let ((port (open-output-file output-specifier)))
- (let ((value (receiver port)))
- (close-output-port port)
- value)))
-
-(define (close-output-port port)
- ((access :close port)))
-\f
-;;;; Console Output Port
-
-(define beep
- (make-primitive-procedure 'TTY-BEEP))
-
-(define (screen-clear)
- ((access :clear-screen console-output-port))
- ((access :flush-output console-output-port)))
-
-(define console-output-port)
-(let ()
-
-(define tty-write-char
- (make-primitive-procedure 'TTY-WRITE-CHAR))
-
-(define tty-write-string
- (make-primitive-procedure 'TTY-WRITE-STRING))
-
-(define tty-flush-output
- (make-primitive-procedure 'TTY-FLUSH-OUTPUT))
-
-(define tty-clear
- (make-primitive-procedure 'TTY-CLEAR))
-
-(set! console-output-port
- (make-environment
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Console output port"))))
-
-(define (:close) 'DONE)
-(define :write-char tty-write-char)
-(define :write-string tty-write-string)
-(define :flush-output tty-flush-output)
-(define :clear-screen tty-clear)
-
-(define (:x-size)
- (access printer-width implementation-dependencies))
-
-(define (:y-size)
- (access printer-length implementation-dependencies))
-
-;;; end CONSOLE-OUTPUT-PORT.
-))
-
-)
-
-(set! *current-output-port* console-output-port)
-\f
-;;; File Output Ports
-
-(define open-output-file)
-(let ()
-#|
-(declare (integrate-primitive-procedures file-write-char file-write-string))
-|#
-(define file-write-char
- (make-primitive-procedure 'FILE-WRITE-CHAR))
-
-(define file-write-string
- (make-primitive-procedure 'FILE-WRITE-STRING))
-
-(set! open-output-file
-(named-lambda (open-output-file filename)
- (make-file-output-port
- ((access open-output-channel primitive-io)
- (canonicalize-output-filename filename)))))
-
-(define (make-file-output-port file-channel)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port for file: ")
- (write ((access channel-name primitive-io) file-channel)))))
-
-(define (:close)
- ((access close-physical-channel primitive-io) file-channel))
-
-(define (:write-char char)
- (file-write-char char file-channel))
-
-(define (:write-string string)
- (file-write-string string file-channel))
-
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
-
-;;; end MAKE-FILE-OUTPUT-PORT.
-(the-environment))
-
-)
-\f
-;;;; String Output Ports
-
-(define (write-to-string object #!optional max)
- (if (unassigned? max) (set! max false))
- (if (not max)
- (with-output-to-string
- (lambda ()
- (write object)))
- (with-output-to-truncated-string max
- (lambda ()
- (write object)))))
-
-(define (with-output-to-string thunk)
- (let ((port (string-output-port)))
- (fluid-let ((*current-output-port* port))
- (thunk))
- ((access :value port))))
-
-(define (string-output-port)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port to string"))))
-
-(define accumulator '())
-
-(define (:value)
- (let ((string (apply string-append (reverse! accumulator))))
- (set! accumulator (list string))
- string))
-
-(define (:write-char char)
- (set! accumulator (cons (char->string char) accumulator)))
-
-(define (:write-string string)
- (set! accumulator (cons string accumulator)))
-
-(define (:close) 'DONE)
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
-
-;;; end STRING-OUTPUT-PORT.
-(the-environment))
-\f
-(define (with-output-to-truncated-string maxsize thunk)
- (call-with-current-continuation
- (lambda (return)
-
-(define :type output-port-tag)
-
-(define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "Output port to truncated string"))))
-
-(define accumulator '())
-(define counter maxsize)
-
-(define (:write-char char)
- (:write-string (char->string char)))
-
-(define (:write-string string)
- (set! accumulator (cons string accumulator))
- (set! counter (- counter (string-length string)))
- (if (negative? counter)
- (return (cons true
- (substring (apply string-append (reverse! accumulator))
- 0 maxsize)))))
-
-(define (:close) 'DONE)
-(define (:flush-output) 'DONE)
-(define (:x-size) false)
-(define (:y-size) false)
-
-(fluid-let ((*current-output-port* (the-environment)))
- (thunk))
-(cons false (apply string-append (reverse! accumulator)))
-
-;;; end WITH-OUTPUT-TO-TRUNCATED-STRING.
-)))
-\f
-;;;; Output Procedures
-
-(define (write-char char #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-char port) char)
- ((access :flush-output port))
- *the-non-printing-object*)
-
-(define (write-string string #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-string port) string)
- ((access :flush-output port))
- *the-non-printing-object*)
-
-(define (newline #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- ((access :write-char port) char:newline)
- ((access :flush-output port))
- *the-non-printing-object*)
-
-(define (display object #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- (if (not (non-printing-object? object))
- (begin (if (and (not (future? object)) (string? object))
- ((access :write-string port) object)
- ((access unparse-object unparser-package) object port false))
- ((access :flush-output port))))
- *the-non-printing-object*)
-
-(define (write object #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- (if (not (non-printing-object? object))
- (begin ((access unparse-object unparser-package) object port)
- ((access :flush-output port))))
- *the-non-printing-object*)
-
-(define (write-line object #!optional port)
- (cond ((unassigned? port) (set! port *current-output-port*))
- ((not (output-port? port)) (error "Bad output port" port)))
- (if (not (non-printing-object? object))
- (begin ((access :write-char port) char:newline)
- ((access unparse-object unparser-package) object port)
- ((access :flush-output port))))
- *the-non-printing-object*)
-
-(define (non-printing-object? object)
- (and (not (future? object))
- ((access :flush-output port))))))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/parse.scm,v 13.42 1987/03/17 18:51:44 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Scheme Parser
-
-(declare (usual-integrations))
-\f
-(define *parser-radix* #d10)
-(define *parser-table*)
-
-(define parser-package
- (make-environment
-
-(define *parser-parse-object-table*)
-(define *parser-collect-list-table*)
-(define *parser-parse-object-special-table*)
-(define *parser-collect-list-special-table*)
-(define *parser-peek-char*)
-(define *parser-discard-char*)
-(define *parser-read-char*)
-(define *parser-read-string*)
-(define *parser-discard-chars*)
-(define *parser-input-port*)
-
-(define (*parse-object port)
- (fluid-let ((*parser-input-port* port)
- (*parser-parse-object-table* (caar *parser-table*))
- (*parser-collect-list-table* (cdar *parser-table*))
- (*parser-parse-object-special-table* (cadr *parser-table*))
- (*parser-collect-list-special-table* (cddr *parser-table*))
- (*parser-peek-char* (access :peek-char port))
- (*parser-discard-char* (access :discard-char port))
- (*parser-read-char* (access :read-char port))
- (*parser-read-string* (access :read-string port))
- (*parser-discard-chars* (access :discard-chars port)))
- (parse-object)))
-
-(define (*parse-objects-until-eof port)
- (fluid-let ((*parser-input-port* port)
- (*parser-parse-object-table* (caar *parser-table*))
- (*parser-collect-list-table* (cdar *parser-table*))
- (*parser-parse-object-special-table* (cadr *parser-table*))
- (*parser-collect-list-special-table* (cddr *parser-table*))
- (*parser-peek-char* (access :peek-char port))
- (*parser-discard-char* (access :discard-char port))
- (*parser-read-char* (access :read-char port))
- (*parser-read-string* (access :read-string port))
- (*parser-discard-chars* (access :discard-chars port)))
- (define (loop object)
- (if (eof-object? object)
- '()
- (cons object (loop (parse-object)))))
- (loop (parse-object))))
-\f
-;;;; Character Operations
-
-(declare (integrate peek-char read-char discard-char
- read-string discard-chars))
-
-(define (peek-char)
- (or (*parser-peek-char*)
- (error "End of file within READ")))
-
-(define (read-char)
- (or (*parser-read-char*)
- (error "End of file within READ")))
-
-(define (discard-char)
- (*parser-discard-char*))
-
-(define (read-string delimiters)
- (declare (integrate delimiters))
- (*parser-read-string* delimiters))
-
-(define (discard-chars delimiters)
- (declare (integrate delimiters))
- (*parser-discard-chars* delimiters))
-\f
-;;; There are two major dispatch tables, one for parsing at top level,
-;;; the other for parsing the elements of a list. Most of the entries
-;;; for each table are have similar actions.
-
-;;; Default is atomic object. Parsing an atomic object does not
-;;; consume its terminator. Thus different terminators [such as open
-;;; paren, close paren, and whitespace], can have different effects on
-;;; parser.
-
-(define (parse-object:atom)
- (build-atom (read-atom)))
-
-(define ((collect-list-wrapper object-parser))
- (let ((value (object-parser))) ;forces order.
- (cons value (collect-list))))
-
-(define (parse-undefined-special)
- (error "No such special reader macro" (peek-char)))
-
-(set! *parser-table*
- (cons (cons (vector-cons 256 parse-object:atom)
- (vector-cons 256 (collect-list-wrapper parse-object:atom)))
- (cons (vector-cons 256 parse-undefined-special)
- (vector-cons 256 parse-undefined-special))))
-
-(define ((parser-char-definer tables)
- char/chars procedure #!optional list-procedure)
- (if (unassigned? list-procedure)
- (set! list-procedure (collect-list-wrapper procedure)))
- (define (do-it char)
- (vector-set! (car tables) (char->ascii char) procedure)
- (vector-set! (cdr tables) (char->ascii char) list-procedure))
- (cond ((char? char/chars) (do-it char/chars))
- ((char-set? char/chars)
- (for-each do-it (char-set-members char/chars)))
- ((pair? char/chars) (for-each do-it char/chars))
- (else (error "Unknown character" char/chars))))
-
-(define define-char
- (parser-char-definer (car *parser-table*)))
-
-(define define-char-special
- (parser-char-definer (cdr *parser-table*)))
-\f
-(declare (integrate peek-ascii parse-object collect-list))
-
-(define (peek-ascii)
- (or (char-ascii? (peek-char))
- (non-ascii-error)))
-
-(define (non-ascii-error)
- (error "Non-ASCII character encountered during parse" (read-char)))
-
-(define (parse-object)
- (let ((char (*parser-peek-char*)))
- (if char
- ((vector-ref *parser-parse-object-table*
- (or (char-ascii? char)
- (non-ascii-error))))
- eof-object)))
-
-(define (collect-list)
- ((vector-ref *parser-collect-list-table* (peek-ascii))))
-
-(define-char #\#
- (lambda ()
- (discard-char)
- ((vector-ref *parser-parse-object-special-table* (peek-ascii))))
- (lambda ()
- (discard-char)
- ((vector-ref *parser-collect-list-special-table* (peek-ascii)))))
-
-(define numeric-leaders
- (char-set-union char-set:numeric
- (char-set #\+ #\- #\. #\#)))
-
-(define undefined-atom-delimiters
- (char-set #\[ #\] #\{ #\} #\|))
-
-(define atom-delimiters
- (char-set-union char-set:whitespace
- (char-set-union undefined-atom-delimiters
- (char-set #\( #\) #\; #\" #\' #\`))))
-
-(define atom-constituents
- (char-set-invert atom-delimiters))
-
-(declare (integrate read-atom))
-
-(define (read-atom)
- (read-string atom-delimiters))
-\f
-(define (build-atom string)
- (or (parse-number string)
- (intern-string! string)))
-
-(declare (integrate parse-number))
-
-(define (parse-number string)
- (declare (integrate string))
- (string->number string false *parser-radix*))
-
-(define (intern-string! string)
- (substring-upcase! string 0 (string-length string))
- (string->symbol string))
-
-(define-char (char-set-difference atom-constituents numeric-leaders)
- (lambda ()
- (intern-string! (read-atom))))
-
-(let ((numeric-prefix
- (lambda ()
- (let ((number
- (let ((char (read-char)))
- (string-append (char->string #\# char) (read-atom)))))
- (or (parse-number number)
- (error "READ: Bad number syntax" number))))))
- (define-char-special '(#\b #\B) numeric-prefix)
- (define-char-special '(#\o #\O) numeric-prefix)
- (define-char-special '(#\d #\D) numeric-prefix)
- (define-char-special '(#\x #\X) numeric-prefix)
- (define-char-special '(#\i #\I) numeric-prefix)
- (define-char-special '(#\e #\E) numeric-prefix)
- (define-char-special '(#\s #\S) numeric-prefix)
- (define-char-special '(#\l #\L) numeric-prefix))
-
-(define-char #\(
- (lambda ()
- (discard-char)
- (collect-list)))
-
-(define-char-special #\(
- (lambda ()
- (discard-char)
- (list->vector (collect-list))))
-
-(define-char #\)
- (lambda ()
- (if (not (eq? console-input-port *parser-input-port*))
- (error "PARSE-OBJECT: Unmatched close paren" (read-char))
- (read-char))
- (parse-object))
- (lambda ()
- (discard-char)
- '()))
-\f
-(define-char undefined-atom-delimiters
- (lambda ()
- (error "PARSE-OBJECT: Undefined atom delimiter" (read-char))
- (parse-object))
- (lambda ()
- (error "PARSE-OBJECT: Undefined atom delimiter" (read-char))
- (collect-list)))
-
-(let ()
-
-(vector-set! (cdar *parser-table*)
- (char->ascii #\.)
- (lambda ()
- (discard-char)
- ;; atom with initial dot?
- (if (char-set-member? atom-constituents (peek-char))
- (let ((first (build-atom (string-append "." (read-atom)))))
- (cons first (collect-list)))
-
- ;; (A . B) -- get B and ignore whitespace following it.
- (let ((tail (parse-object)))
- (discard-whitespace)
- (if (not (char=? (peek-char) #\)))
- (error "Illegal character in ignored stream" (peek-char)))
- (discard-char)
- tail))))
-
-(define-char char-set:whitespace
- (lambda ()
- (discard-whitespace)
- (parse-object))
- (lambda ()
- (discard-whitespace)
- (collect-list)))
-
-(define (discard-whitespace)
- (discard-chars non-whitespace))
-
-(define non-whitespace
- (char-set-invert char-set:whitespace))
-
-)
-\f
-(let ()
-
-(define-char #\;
- (lambda ()
- (discard-comment)
- (parse-object))
- (lambda ()
- (discard-comment)
- (collect-list)))
-
-(define (discard-comment)
- (discard-char)
- (discard-chars comment-delimiters)
- (discard-char))
-
-(define comment-delimiters
- (char-set char:newline))
-
-)
-
-(let ()
-
-(define-char-special #\|
- (lambda ()
- (discard-char)
- (discard-special-comment)
- (parse-object))
- (lambda ()
- (discard-char)
- (discard-special-comment)
- (collect-list)))
-
-(define (discard-special-comment)
- (discard-chars special-comment-leaders)
- (if (char=? #\| (read-char))
- (if (char=? #\# (peek-char))
- (discard-char)
- (discard-special-comment))
- (begin (if (char=? #\| (peek-char))
- (begin (discard-char)
- (discard-special-comment)))
- (discard-special-comment))))
-
-(define special-comment-leaders
- (char-set #\# #\|))
-
-)
-\f
-(define-char #\'
- (lambda ()
- (discard-char)
- (list 'QUOTE (parse-object))))
-
-(define-char #\`
- (lambda ()
- (discard-char)
- (list 'QUASIQUOTE (parse-object))))
-
-(define-char #\,
- (lambda ()
- (discard-char)
- (if (char=? #\@ (peek-char))
- (begin (discard-char)
- (list 'UNQUOTE-SPLICING (parse-object)))
- (list 'UNQUOTE (parse-object)))))
-
-(define-char #\"
- (let ((delimiters (char-set #\" #\\)))
- (lambda ()
- (define (loop string)
- (if (char=? #\" (read-char))
- string
- (let ((char (read-char)))
- (string-append string
- (char->string
- (cond ((char-ci=? char #\t) #\Tab)
- ((char-ci=? char #\n) char:newline)
- ((char-ci=? char #\f) #\Page)
- (else char)))
- (loop (read-string delimiters))))))
- (discard-char)
- (loop (read-string delimiters)))))
-\f
-(define-char-special #\\
- (let ((delimiters (char-set-union (char-set #\- #\\) atom-delimiters)))
- (lambda ()
- (define (loop)
- (cond ((char=? #\\ (peek-char))
- (discard-char)
- (char->string (read-char)))
- ((char-set-member? delimiters (peek-char))
- (char->string (read-char)))
- (else
- (let ((string (read-string delimiters)))
- (if (char=? #\- (peek-char))
- (begin (discard-char)
- (string-append string "-" (loop)))
- string)))))
- (discard-char)
- (if (char=? #\\ (peek-char))
- (read-char)
- (name->char (loop))))))
-
-(define ((fixed-object-parser object))
- (discard-char)
- object)
-
-(define-char-special '(#\f #\F) (fixed-object-parser false))
-(define-char-special '(#\t #\T) (fixed-object-parser true))
-
-(define-char-special #\!
- (lambda ()
- (discard-char)
- (let ((object-name (parse-object)))
- (cdr (or (assq object-name named-objects)
- (error "No object by this name" object-name))))))
-
-(define named-objects
- `((NULL . ,(list))
- (FALSE . ,(eq? 'TRUE 'FALSE))
- (TRUE . ,(eq? 'TRUE 'TRUE))
- (OPTIONAL . ,(access lambda-optional-tag lambda-package))
- (REST . ,(access lambda-rest-tag lambda-package))))
-
-;;; end PARSER-PACKAGE.
-))
-\f
-;;;; Parser Tables
-
-(define (parser-table-copy table)
- (cons (cons (vector-copy (caar table))
- (vector-copy (cdar table)))
- (cons (vector-copy (cadr table))
- (vector-copy (cddr table)))))
-
-(define parser-table-entry)
-(define set-parser-table-entry!)
-(let ()
-
-(define (decode-parser-char table char receiver)
- (cond ((char? char)
- (receiver (car table) (char->ascii char)))
- ((string? char)
- (cond ((= (string-length char) 1)
- (receiver (car table) (char->ascii (string-ref char 0))))
- ((and (= (string-length char) 2)
- (char=? #\# (string-ref char 0)))
- (receiver (cdr table) (char->ascii (string-ref char 1))))
- (else
- (error "Bad character" 'DECODE-PARSER-CHAR char))))
- (else
- (error "Bad character" 'DECODE-PARSER-CHAR char))))
-
-(define (ptable-ref table index)
- (cons (vector-ref (car table) index)
- (vector-ref (cdr table) index)))
-
-(define (ptable-set! table index value)
- (vector-set! (car table) index (car value))
- (vector-set! (cdr table) index (cdr value)))
-
-(set! parser-table-entry
-(named-lambda (parser-table-entry table char)
- (decode-parser-char table char ptable-ref)))
-
-(set! set-parser-table-entry!
-(named-lambda (set-parser-table-entry! table char entry)
- (decode-parser-char table char
- (lambda (sub-table index)
- (ptable-set! sub-table index entry)))))
-
-)
-
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 13.42 1987/03/12 02:16:14 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Pathnames
-
-(declare (usual-integrations))
-\f
-;;; A pathname component is normally one of:
-
-;;; * A string, which is the literal component.
-
-;;; * 'WILD, meaning that the component is wildcarded. Such
-;;; components may have special meaning to certain directory
-;;; operations.
-
-;;; * 'UNSPECIFIC, meaning that the component was supplied, but null.
-;;; This means about the same thing as "". (maybe it should be
-;;; eliminated in favor of that?)
-
-;;; * #F, meaning that the component was not supplied. This has
-;;; special meaning to `merge-pathnames', in which such components are
-;;; substituted.
-
-;;; A pathname consists of 5 components, not all necessarily
-;;; meaningful, as follows:
-
-;;; * The DEVICE is usually a physical device, as in the Twenex `ps:'.
-
-;;; * The DIRECTORY is a list of components. If the first component
-;;; is the null string, then the directory path is absolute.
-;;; Otherwise it is relative.
-
-;;; * The NAME is the proper name part of the filename.
-
-;;; * The TYPE usually indicates something about the contents of the
-;;; file. Certain system procedures will default the type to standard
-;;; type strings.
-
-;;; * The VERSION is special. Unlike an ordinary component, it is
-;;; never a string, but may be either a positive integer, 'NEWEST,
-;;; 'WILD, 'UNSPECIFIC, or #F. Many system procedures will default
-;;; the version to 'NEWEST, which means to search the directory for
-;;; the highest version numbered file.
-
-;;; This file requires the following procedures and variables which
-;;; define the conventions for the particular file system in use:
-;;;
-;;; (symbol->pathname symbol)
-;;; (string->pathname string)
-;;; (pathname-unparse device directory name type version)
-;;; (pathname-unparse-name name type version)
-;;; (simplify-directory directory)
-;;; working-directory-package
-;;; (access reset! working-directory-package)
-;;; init-file-pathname
-;;; (home-directory-pathname)
-;;; (working-directory-pathname)
-;;; (set-working-directory-pathname! name)
-;;;
-;;; See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.
-\f
-;;;; Basic Pathnames
-
-(define (pathname? object)
- (and (environment? object)
- (eq? (environment-procedure object) make-pathname)))
-
-(define (make-pathname device directory name type version)
- (define string #F)
-
- (define (:print-self)
- (unparse-with-brackets
- (lambda ()
- (write-string "PATHNAME ")
- (write (pathname->string (the-environment))))))
-
- (the-environment))
-
-(define (pathname-components pathname receiver)
- (receiver (access device pathname)
- (access directory pathname)
- (access name pathname)
- (access type pathname)
- (access version pathname)))
-
-(define (pathname-device pathname)
- (access device pathname))
-
-(define (pathname-directory pathname)
- (access directory pathname))
-
-(define (pathname-name pathname)
- (access name pathname))
-
-(define (pathname-type pathname)
- (access type pathname))
-
-(define (pathname-version pathname)
- (access version pathname))
-
-(define (pathname-extract pathname . fields)
- (pathname-components pathname
- (lambda (device directory name type version)
- (make-pathname (and (memq 'DEVICE fields) device)
- (and (memq 'DIRECTORY fields) directory)
- (and (memq 'NAME fields) name)
- (and (memq 'TYPE fields) type)
- (and (memq 'VERSION fields) version)))))
-
-(define (pathname-absolute? pathname)
- (let ((directory (pathname-directory pathname)))
- (and (not (null? directory))
- (string-null? (car directory)))))
-\f
-(define (pathname-new-device pathname device)
- (pathname-components pathname
- (lambda (old-device directory name type version)
- (make-pathname device directory name type version))))
-
-(define (pathname-new-directory pathname directory)
- (pathname-components pathname
- (lambda (device old-directory name type version)
- (make-pathname device directory name type version))))
-
-(define (pathname-new-name pathname name)
- (pathname-components pathname
- (lambda (device directory old-name type version)
- (make-pathname device directory name type version))))
-
-(define (pathname-new-type pathname type)
- (pathname-components pathname
- (lambda (device directory name old-type version)
- (make-pathname device directory name type version))))
-
-(define (pathname-new-version pathname version)
- (pathname-components pathname
- (lambda (device directory name type old-version)
- (make-pathname device directory name type version))))
-
-(define (pathname-directory-path pathname)
- (pathname-components pathname
- (lambda (device directory name type version)
- (make-pathname device directory #F #F #F))))
-
-(define (pathname-directory-string pathname)
- (pathname-components pathname
- (lambda (device directory name type version)
- (pathname-unparse device directory #F #F #F))))
-
-(define (pathname-name-path pathname)
- (pathname-components pathname
- (lambda (device directory name type version)
- (make-pathname #F #F name type version))))
-
-(define (pathname-name-string pathname)
- (pathname-components pathname
- (lambda (device directory name type version)
- (pathname-unparse #F #F name type version))))
-\f
-;;;; Parse and unparse.
-
-;;; Defined in terms of operating system dependent procedures.
-
-(define (->pathname object)
- (cond ((pathname? object) object)
- ((string? object) (string->pathname object))
- ((symbol? object) (symbol->pathname object))
- (else (error "Unable to coerce into pathname" object))))
-
-(define (pathname->string pathname)
- (or (access string pathname)
- (let ((string (pathname-components pathname pathname-unparse)))
- (set! (access string pathname) string)
- string)))
-
-(define (pathname-extract-string pathname . fields)
- (pathname-components pathname
- (lambda (device directory name type version)
- (pathname-unparse (and (memq 'DEVICE fields) device)
- (and (memq 'DIRECTORY fields) directory)
- (and (memq 'NAME fields) name)
- (and (memq 'TYPE fields) type)
- (and (memq 'VERSION fields) version)))))
-\f
-;;;; Merging pathnames
-
-(define (merge-pathnames pathname default)
- (make-pathname (or (pathname-device pathname) (pathname-device default))
- (simplify-directory
- (let ((directory (pathname-directory pathname)))
- (cond ((null? directory) (pathname-directory default))
- ((string-null? (car directory)) directory)
- (else
- (append (pathname-directory default) directory)))))
- (or (pathname-name pathname) (pathname-name default))
- (or (pathname-type pathname) (pathname-type default))
- (or (pathname-version pathname) (pathname-version default))))
-
-(define (pathname-as-directory pathname)
- (let ((file (pathname-unparse-name (pathname-name pathname)
- (pathname-type pathname)
- (pathname-version pathname))))
- (if (string-null? file)
- pathname
- (make-pathname (pathname-device pathname)
- (append (pathname-directory pathname)
- (list file))
- #F #F #F))))
-
-(define (pathname->absolute-pathname pathname)
- (merge-pathnames pathname (working-directory-pathname)))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pp.scm,v 13.42 1987/03/17 18:52:08 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Pretty Printer
-
-(declare (usual-integrations))
-\f
-(define scheme-pretty-printer
- (make-environment
-
-(define *pp-primitives-by-name* true)
-(define *forced-x-size* false)
-(define *default-x-size* 80)
-
-(define x-size)
-(define next-coords)
-(define add-sc-entry!)
-(define sc-relink!)
-
-(declare (integrate *unparse-string *unparse-char))
-
-(define (*unparse-string string)
- (declare (integrate string))
- ((access :write-string *current-output-port*) string))
-
-(define (*unparse-char char)
- (declare (integrate char))
- ((access :write-char *current-output-port*) char))
-
-(define (*unparse-open)
- (*unparse-char #\())
-
-(define (*unparse-close)
- (*unparse-char #\)))
-
-(define (*unparse-space)
- (*unparse-char #\Space))
-
-(define (*unparse-newline)
- (*unparse-char char:newline))
-\f
-;;;; Top Level
-
-(define (pp expression as-code?)
- (fluid-let ((x-size (get-x-size)))
- (let ((node (numerical-walk expression)))
- (*unparse-newline)
- ((if as-code? print-node print-non-code-node) node 0 0)
- ((access :flush-output *current-output-port*)))))
-
-(define (stepper-pp expression port p-wrapper table nc relink! sc! offset)
- (fluid-let ((x-size (get-x-size))
- (walk-dispatcher table)
- (next-coords nc)
- (sc-relink! relink!)
- (add-sc-entry! sc!)
- (print-combination (p-wrapper print-combination))
- (forced-indentation (p-wrapper forced-indentation))
- (pressured-indentation (p-wrapper pressured-indentation))
- (print-procedure (p-wrapper print-procedure))
- (print-let-expression (p-wrapper print-let-expression))
- (print-node (p-wrapper print-node))
- (print-guaranteed-node (p-wrapper print-guaranteed-node)))
- (let ((node (numerical-walk expression)))
- (with-output-to-port port
- (lambda ()
- (print-node node (car offset) 0)
- ((access :flush-output *current-output-port*)))))))
-
-(define (get-x-size)
- (or *forced-x-size*
- ((access :x-size *current-output-port*))
- *default-x-size*))
-
-(define (print-non-code-node node column depth)
- (fluid-let ((dispatch-list '()))
- (print-node node column depth)))
-
-(define (print-node node column depth)
- (cond ((list-node? node) (print-list-node node column depth))
- ((symbol? node) (*unparse-symbol node))
- ((prefix-node? node) (*unparse-string (node-prefix node))
- (print-node (node-subnode node)
- (+ (string-length (node-prefix node)) column)
- depth))
- (else (*unparse-string node))))
-
-(define (print-list-node node column depth)
- (if (fits-within? node column depth)
- (print-guaranteed-list-node node)
- (let ((subnodes (node-subnodes node)))
- ((or (let ((association (assq (car subnodes) dispatch-list)))
- (and association (cdr association)))
- print-combination)
- subnodes column depth))))
-\f
-(define (print-guaranteed-node node)
- (cond ((list-node? node) (print-guaranteed-list-node node))
- ((symbol? node) (*unparse-symbol node))
- ((prefix-node? node)
- (*unparse-string (node-prefix node))
- (print-guaranteed-node (node-subnode node)))
- (else (*unparse-string node))))
-
-(define (print-guaranteed-list-node node)
- (define (loop nodes)
- (print-guaranteed-node (car nodes))
- (if (not (null? (cdr nodes)))
- (begin (*unparse-space)
- (loop (cdr nodes)))))
- (*unparse-open)
- (loop (node-subnodes node))
- (*unparse-close))
-
-(define (print-column nodes column depth)
- (define (loop nodes)
- (if (null? (cdr nodes))
- (print-node (car nodes) column depth)
- (begin (print-node (car nodes) column 0)
- (tab-to column)
- (loop (cdr nodes)))))
- (loop nodes))
-
-(define (print-guaranteed-column nodes column)
- (define (loop nodes)
- (print-guaranteed-node (car nodes))
- (if (not (null? (cdr nodes)))
- (begin (tab-to column)
- (loop (cdr nodes)))))
- (loop nodes))
-\f
-;;;; Printers
-
-(define (print-combination nodes column depth)
- (*unparse-open)
- (let ((column (1+ column)) (depth (1+ depth)))
- (cond ((null? (cdr nodes))
- (print-node (car nodes) column depth))
- ((two-on-first-line? nodes column depth)
- (print-guaranteed-node (car nodes))
- (*unparse-space)
- (print-guaranteed-column (cdr nodes)
- (1+ (+ column (node-size (car nodes))))))
- (else
- (print-column nodes column depth))))
- (*unparse-close))
-
-(define ((special-printer procedure) nodes column depth)
- (*unparse-open)
- (*unparse-symbol (car nodes))
- (*unparse-space)
- (if (not (null? (cdr nodes)))
- (procedure (cdr nodes)
- (+ 2 (+ column (symbol-length (car nodes))))
- (+ 2 column)
- (1+ depth)))
- (*unparse-close))
-
-;;; Force the indentation to be an optimistic column.
-
-(define forced-indentation
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (print-column nodes optimistic depth))))
-
-;;; Pressure the indentation to be an optimistic column; no matter
-;;; what happens, insist on a column, but accept a pessimistic one if
-;;; necessary.
-
-(define pressured-indentation
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (if (fits-as-column? nodes optimistic depth)
- (print-guaranteed-column nodes optimistic)
- (begin (tab-to pessimistic)
- (print-column nodes pessimistic depth))))))
-\f
-;;; Print a procedure definition. The bound variable pattern goes on
-;;; the same line as the keyword, while everything else gets indented
-;;; pessimistically. We may later want to modify this to make higher
-;;; order procedure patterns be printed more carefully.
-
-(define print-procedure
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (print-node (car nodes) optimistic 0)
- (tab-to pessimistic)
- (print-column (cdr nodes) pessimistic depth))))
-
-;;; Print a binding form. There is a great deal of complication here,
-;;; some of which is to gracefully handle the case of a badly-formed
-;;; binder. But most important is the code that handles the name when
-;;; we encounter a named LET; it must go on the same line as the
-;;; keyword. In that case, the bindings try to fit on that line or
-;;; start on that line if possible; otherwise they line up under the
-;;; name. The body, of course, is always indented pessimistically.
-
-(define print-let-expression
- (special-printer
- (lambda (nodes optimistic pessimistic depth)
- (define (print-body nodes)
- (if (not (null? nodes))
- (begin (tab-to pessimistic)
- (print-column nodes pessimistic depth))))
- (cond ((null? (cdr nodes)) ;Screw case.
- (print-node (car nodes) optimistic depth))
- ((symbol? (car nodes)) ;Named LET.
- (*unparse-symbol (car nodes))
- (let ((new-optimistic
- (1+ (+ optimistic (symbol-length (car nodes))))))
- (cond ((fits-within? (cadr nodes) new-optimistic 0)
- (*unparse-space)
- (print-guaranteed-node (cadr nodes))
- (print-body (cddr nodes)))
- ((fits-as-column? (node-subnodes (cadr nodes))
- (+ new-optimistic 2)
- 0)
- (*unparse-space)
- (*unparse-open)
- (print-guaranteed-column (node-subnodes (cadr nodes))
- (1+ new-optimistic))
- (*unparse-close)
- (print-body (cddr nodes)))
- (else
- (tab-to optimistic)
- (print-node (cadr nodes) optimistic 0)
- (print-body (cddr nodes))))))
- (else ;Ordinary LET.
- (print-node (car nodes) optimistic 0)
- (print-body (cdr nodes)))))))
-\f
-(define dispatch-list
- `((COND . ,forced-indentation)
- (IF . ,forced-indentation)
- (OR . ,forced-indentation)
- (AND . ,forced-indentation)
- (LET . ,print-let-expression)
- (FLUID-LET . ,print-let-expression)
- (DEFINE . ,print-procedure)
- (LAMBDA . ,print-procedure)
- (NAMED-LAMBDA . ,print-procedure)))
-
-;;;; Alignment
-
-(declare (integrate fits-within?))
-
-(define (fits-within? node column depth)
- (declare (integrate node column depth))
- (> (- x-size depth)
- (+ column (node-size node))))
-
-;;; Fits if each node fits when stacked vertically at the given column.
-
-(define (fits-as-column? nodes column depth)
- (define (loop nodes)
- (if (null? (cdr nodes))
- (fits-within? (car nodes) column depth)
- (and (> x-size
- (+ column (node-size (car nodes))))
- (loop (cdr nodes)))))
- (loop nodes))
-
-;;; Fits if first two nodes fit on same line, and rest fit under the
-;;; second node. Assumes at least two nodes are given.
-
-(define (two-on-first-line? nodes column depth)
- (let ((column (1+ (+ column (node-size (car nodes))))))
- (and (> x-size column)
- (fits-as-column? (cdr nodes) column depth))))
-
-;;; Starts a new line with the specified indentation.
-
-(define (tab-to column)
- (*unparse-newline)
- (*unparse-string (make-string column #\Space)))
-\f
-;;;; Numerical Walk
-
-(define (numerical-walk object)
- ((walk-dispatcher object) object))
-
-(define (walk-general object)
- (write-to-string object))
-
-(define (walk-primitive primitive)
- (if *pp-primitives-by-name*
- (primitive-procedure-name primitive)
- (write-to-string primitive)))
-
-(define (walk-pair pair)
- (if (and (eq? (car pair) 'QUOTE)
- (pair? (cdr pair))
- (null? (cddr pair)))
- (make-prefix-node "'" (numerical-walk (cadr pair)))
- (walk-unquoted-pair pair)))
-
-(define (walk-unquoted-pair pair)
- (if (null? (cdr pair))
- (make-singleton-list-node (numerical-walk (car pair)))
- (make-list-node
- (numerical-walk (car pair))
- (if (pair? (cdr pair))
- (walk-unquoted-pair (cdr pair))
- (make-singleton-list-node
- (make-prefix-node ". " (numerical-walk (cdr pair))))))))
-
-(define (walk-vector vector)
- (if (zero? (vector-length vector))
- "#()"
- (make-prefix-node "#" (walk-unquoted-pair (vector->list vector)))))
-
-(define walk-dispatcher
- (make-type-dispatcher
- `((,symbol-type ,identity-procedure)
- (,primitive-procedure-type ,walk-primitive)
- (,(microcode-type-object 'PAIR) ,walk-pair)
- (,(microcode-type-object 'VECTOR) ,walk-vector)
- (,unparser-special-object-type ,walk-general))
- walk-general))
-\f
-;;;; Node Model
-;;; Carefully crafted to use the least amount of memory, while at the
-;;; same time being as fast as possible. The only concession to
-;;; space was in the implementation of atomic nodes, in which it was
-;;; decided that the extra space needed to cache the size of a string
-;;; or the print-name of a symbol wasn't worth the speed that would
-;;; be gained by keeping it around.
-
-(declare (integrate symbol-length *unparse-symbol))
-
-(define (symbol-length symbol)
- (declare (integrate symbol))
- (string-length (symbol->string symbol)))
-
-(define (*unparse-symbol symbol)
- (declare (integrate symbol))
- (*unparse-string (symbol->string symbol)))
-
-(define (make-prefix-node prefix subnode)
- (cond ((or (list-node? subnode)
- (symbol? subnode))
- (vector (+ (string-length prefix) (node-size subnode))
- prefix
- subnode))
- ((prefix-node? subnode)
- (make-prefix-node (string-append prefix (node-prefix subnode))
- (node-subnode subnode)))
- (else (string-append prefix subnode))))
-
-(define prefix-node? vector?)
-(define prefix-node-size vector-first)
-(define node-prefix vector-second)
-(define node-subnode vector-third)
-
-(define (make-list-node car-node cdr-node)
- (cons (1+ (+ (node-size car-node) (list-node-size cdr-node))) ;+1 space.
- (cons car-node (node-subnodes cdr-node))))
-
-(define (make-singleton-list-node car-node)
- (cons (+ 2 (node-size car-node)) ;+1 each parenthesis.
- (list car-node)))
-
-(declare (integrate list-node? list-node-size node-subnodes))
-
-(define list-node? pair?)
-(define list-node-size car)
-(define node-subnodes cdr)
-
-(define (node-size node)
- ((cond ((list-node? node) list-node-size)
- ((symbol? node) symbol-length)
- ((prefix-node? node) prefix-node-size)
- (else string-length))
- node))
-\f
-;;; end SCHEME-PRETTY-PRINTER package.
-))
-
-;;;; Exports
-
-(define pp
- (let ()
- (define (prepare scode)
- (let ((s-expression (unsyntax scode)))
- (if (and (pair? s-expression)
- (eq? (car s-expression) 'NAMED-LAMBDA))
- `(DEFINE ,@(cdr s-expression))
- s-expression)))
-
- (define (bad-arg argument)
- (error "Bad optional argument" 'PP argument))
-
- (lambda (scode . optionals)
- (define (kernel as-code?)
- (if (scode-constant? scode)
- ((access pp scheme-pretty-printer) scode as-code?)
- ((access pp scheme-pretty-printer) (prepare scode) true)))
-
- (cond ((null? optionals)
- (kernel false))
- ((null? (cdr optionals))
- (cond ((eq? (car optionals) 'AS-CODE)
- (kernel true))
- ((output-port? (car optionals))
- (with-output-to-port (car optionals)
- (lambda () (kernel false))))
- (else
- (bad-arg (car optionals)))))
- ((null? (cddr optionals))
- (cond ((eq? (car optionals) 'AS-CODE)
- (if (output-port? (cadr optionals))
- (with-output-to-port (cadr optionals)
- (lambda () (kernel true)))
- (bad-arg (cadr optionals))))
- ((output-port? (car optionals))
- (if (eq? (cadr optionals) 'AS-CODE)
- (with-output-to-port (car optionals)
- (lambda () (kernel true)))
- (bad-arg (cadr optionals))))
- (else
- (bad-arg (car optionals)))))
- (else
- (error "Too many optional arguments" 'PP optionals)))
- *the-non-printing-object*)))
-
-(define (pa procedure)
- (if (not (compound-procedure? procedure))
- (error "Must be a compound procedure" procedure))
- (pp (unsyntax-lambda-list (procedure-lambda procedure))))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/qsort.scm,v 13.41 1987/01/23 00:18:12 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Quick Sort
-
-(declare (usual-integrations))
-\f
-(define (sort obj pred)
- (if (vector? obj)
- (sort! (vector-copy obj) pred)
- (vector->list (sort! (list->vector obj) pred))))
-
-(define sort!
- (let ()
-
- (define (exchange! vec i j)
- ;; Speedup hack uses value of VECTOR-SET!.
- (vector-set! vec j (vector-set! vec i (vector-ref vec j))))
-
- (named-lambda (sort! obj pred)
- (define (sort-internal! vec l r)
- (cond
- ((<= r l)
- vec)
- ((= r (1+ l))
- (if (pred (vector-ref vec r)
- (vector-ref vec l))
- (exchange! vec l r)
- vec))
- (else
- (quick-merge vec l r))))
-
- (define (quick-merge vec l r)
- (let ((first (vector-ref vec l)))
- (define (increase-i i)
- (if (or (> i r)
- (pred first (vector-ref vec i)))
- i
- (increase-i (1+ i))))
- (define (decrease-j j)
- (if (or (<= j l)
- (not (pred first (vector-ref vec j))))
- j
- (decrease-j (-1+ j))))
- (define (loop i j)
- (if (< i j) ;* used to be <=
- (begin (exchange! vec i j)
- (loop (increase-i (1+ i)) (decrease-j (-1+ j))))
- (begin (if (> j l)
- (exchange! vec j l))
- (sort-internal! vec (1+ j) r)
- (sort-internal! vec l (-1+ j)))))
- (loop (increase-i (1+ l))
- (decrease-j r))))
-
- (if (vector? obj)
- (begin (sort-internal! obj 0 (-1+ (vector-length obj)))
- obj)
- (error "SORT! works on vectors only" obj)))))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 13.42 1987/04/13 18:44:00 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Read-Eval-Print Loop
-
-(declare (usual-integrations))
-\f
-;;;; Command Loops
-
-(define make-command-loop)
-(define push-command-loop)
-(define push-command-hook)
-(define with-rep-continuation)
-(define continue-rep)
-(define rep-continuation)
-(define rep-state)
-(define rep-level)
-(define abort->nearest)
-(define abort->previous)
-(define abort->top-level)
-(let ()
-
-(define top-level-driver-hook)
-(define previous-driver-hook)
-(define nearest-driver-hook)
-(define current-continuation)
-(define current-state)
-(define current-level 0)
-
-;; PUSH-COMMAND-HOOK is provided so that the Butterfly, in particular,
-;; can add its own little code just before creating a REP loop
-(set! push-command-hook
- (lambda (startup driver state continuation)
- (continuation startup driver state (lambda () 'ignore))))
-
-(set! make-command-loop
- (named-lambda (make-command-loop message driver)
- (define (driver-loop message)
- (driver-loop
- (with-rep-continuation
- (lambda (quit)
- (set! top-level-driver-hook quit)
- (set! nearest-driver-hook quit)
- (driver message)))))
- (set-interrupt-enables! interrupt-mask-gc-ok)
- (fluid-let ((top-level-driver-hook)
- (nearest-driver-hook))
- (driver-loop message))))
-\f
-(set! push-command-loop
-(named-lambda (push-command-loop startup-hook driver initial-state)
- (define (restart entry-hook each-time)
- (let ((reentry-hook
- (call-with-current-continuation
- (lambda (again)
- (set! nearest-driver-hook again)
- (set-interrupt-enables! interrupt-mask-all)
- (each-time)
- (entry-hook)
- (loop)))))
- (set-interrupt-enables! interrupt-mask-gc-ok)
- (restart reentry-hook each-time)))
-
- (define (loop)
- (set! current-state (driver current-state))
- (loop))
-
- (fluid-let ((current-level (1+ current-level))
- (previous-driver-hook nearest-driver-hook)
- (nearest-driver-hook)
- (current-state))
- (push-command-hook
- startup-hook driver initial-state
- (lambda (startup-hook driver initial-state each-time)
- (set! current-state initial-state)
- (restart startup-hook each-time))))))
-\f
-(set! with-rep-continuation
-(named-lambda (with-rep-continuation receiver)
- (call-with-current-continuation
- (lambda (raw-continuation)
- (let ((continuation (raw-continuation->continuation raw-continuation)))
- (fluid-let ((current-continuation continuation))
- (receiver continuation)))))))
-
-(set! continue-rep
-(named-lambda (continue-rep value)
- (current-continuation
- (if (eq? current-continuation top-level-driver-hook)
- (lambda ()
- (write-line value))
- value))))
-
-(set! abort->nearest
-(named-lambda (abort->nearest message)
- (nearest-driver-hook message)))
-
-(set! abort->previous
-(named-lambda (abort->previous message)
- ((if (null? previous-driver-hook)
- nearest-driver-hook
- previous-driver-hook)
- message)))
-
-(set! abort->top-level
-(named-lambda (abort->top-level message)
- (top-level-driver-hook message)))
-
-(set! rep-continuation
-(named-lambda (rep-continuation)
- current-continuation))
-
-(set! rep-state
-(named-lambda (rep-state)
- current-state))
-
-(set! rep-level
-(named-lambda (rep-level)
- current-level))
-
-) ; LET
-\f
-;;;; Read-Eval-Print Loops
-
-(define *rep-base-environment*)
-(define *rep-current-environment*)
-(define *rep-base-syntax-table*)
-(define *rep-current-syntax-table*)
-(define *rep-base-prompt*)
-(define *rep-current-prompt*)
-(define *rep-base-input-port*)
-(define *rep-current-input-port*)
-(define *rep-base-output-port*)
-(define *rep-current-output-port*)
-(define *rep-keyboard-map*)
-(define *rep-error-hook*)
-
-(define (rep-environment)
- *rep-current-environment*)
-
-(define (rep-base-environment)
- *rep-base-environment*)
-
-(define (set-rep-environment! environment)
- (set! *rep-current-environment* environment)
- (environment-warning-hook *rep-current-environment*))
-
-(define (set-rep-base-environment! environment)
- (set! *rep-base-environment* environment)
- (set! *rep-current-environment* environment)
- (environment-warning-hook *rep-current-environment*))
-
-(define (rep-syntax-table)
- *rep-current-syntax-table*)
-
-(define (rep-base-syntax-table)
- *rep-base-syntax-table*)
-
-(define (set-rep-syntax-table! syntax-table)
- (set! *rep-current-syntax-table* syntax-table))
-
-(define (set-rep-base-syntax-table! syntax-table)
- (set! *rep-base-syntax-table* syntax-table)
- (set! *rep-current-syntax-table* syntax-table))
-\f
-(define (rep-prompt)
- *rep-current-prompt*)
-
-(define (set-rep-prompt! prompt)
- (set! *rep-current-prompt* prompt))
-
-(define (rep-base-prompt)
- *rep-base-prompt*)
-
-(define (set-rep-base-prompt! prompt)
- (set! *rep-base-prompt* prompt)
- (set! *rep-current-prompt* prompt))
-
-(define (rep-input-port)
- *rep-current-input-port*)
-
-(define (rep-output-port)
- *rep-current-output-port*)
-
-(define environment-warning-hook
- identity-procedure)
-
-(define rep-value-hook
- write-line)
-
-(define make-rep)
-(define push-rep)
-(define reader-history)
-(define printer-history)
-(let ()
-\f
-(set! make-rep
-(named-lambda (make-rep environment syntax-table prompt input-port output-port
- message)
- (fluid-let ((*rep-base-environment* environment)
- (*rep-base-syntax-table* syntax-table)
- (*rep-base-prompt* prompt)
- (*rep-base-input-port* input-port)
- (*rep-base-output-port* output-port)
- (*rep-keyboard-map* (keyboard-interrupt-dispatch-table))
- (*rep-error-hook* (access *error-hook* error-system)))
- (make-command-loop message rep-top-driver))))
-
-(define (rep-top-driver message)
- (push-rep *rep-base-environment* message *rep-base-prompt*))
-
-(set! push-rep
-(named-lambda (push-rep environment message prompt)
- (fluid-let ((*rep-current-environment* environment)
- (*rep-current-syntax-table* *rep-base-syntax-table*)
- (*rep-current-prompt* prompt)
- (*rep-current-input-port* *rep-base-input-port*)
- (*rep-current-output-port* *rep-base-output-port*)
- (*current-input-port* *rep-base-input-port*)
- (*current-output-port* *rep-base-output-port*)
- ((access *error-hook* error-system) *rep-error-hook*))
- (with-keyboard-interrupt-dispatch-table *rep-keyboard-map*
- (lambda ()
- (environment-warning-hook *rep-current-environment*)
- (push-command-loop message
- rep-driver
- (make-rep-state (make-history 5)
- (make-history 10))))))))
-
-(define (rep-driver state)
- (*rep-current-prompt*)
- (let ((object
- (let ((scode
- (let ((s-expression (read)))
- (record-in-history! (rep-state-reader-history state)
- s-expression)
- (syntax s-expression *rep-current-syntax-table*))))
- (with-new-history
- (lambda ()
- (scode-eval scode *rep-current-environment*))))))
- (record-in-history! (rep-state-printer-history state) object)
- (rep-value-hook object))
- state)
-\f
-;;; History Manipulation
-
-(define (make-history size)
- (let ((list (make-list size '())))
- (append! list list)
- (vector history-tag size list)))
-
-(define history-tag
- '(REP-HISTORY))
-
-(define (record-in-history! history object)
- (if (not (null? (vector-ref history 2)))
- (begin (set-car! (vector-ref history 2) object)
- (vector-set! history 2 (cdr (vector-ref history 2))))))
-
-(define (read-history history n)
- (if (not (and (integer? n)
- (not (negative? n))
- (< n (vector-ref history 1))))
- (error "Bad argument: READ-HISTORY" n))
- (list-ref (vector-ref history 2)
- (- (-1+ (vector-ref history 1)) n)))
-
-(define ((history-reader selector name) n)
- (let ((state (rep-state)))
- (if (rep-state? state)
- (read-history (selector state) n)
- (error "Not in REP loop" name))))
-
-(define rep-state-tag
- "REP State")
-
-(define (make-rep-state reader-history printer-history)
- (vector rep-state-tag reader-history printer-history))
-
-(define (rep-state? object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? (vector-ref object 0) rep-state-tag)))
-
-(define rep-state-reader-history vector-second)
-(define rep-state-printer-history vector-third)
-
-(set! reader-history
- (history-reader rep-state-reader-history 'READER-HISTORY))
-
-(set! printer-history
- (history-reader rep-state-printer-history 'PRINTER-HISTORY))
-
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 13.41 1987/01/23 00:18:56 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Definition Scanner
-
-(declare (usual-integrations))
-\f
-;;; Scanning of internal definitions is necessary to reduce the number
-;;; of "real auxiliary" variables in the system. These bindings are
-;;; maintained in alists by the microcode, and cannot be compiled as
-;;; ordinary formals can.
-
-;;; The following support is provided. SCAN-DEFINES will find the
-;;; top-level definitions in a sequence, and returns an ordered list
-;;; of those names, and a new sequence in which those definitions are
-;;; replaced by assignments. UNSCAN-DEFINES will invert that.
-
-;;; The Open Block abstraction can be used to store scanned
-;;; definitions in code, which is extremely useful for code analysis
-;;; and transformation. The supplied procedures, MAKE-OPEN-BLOCK and
-;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
-;;; UNSCAN-DEFINES, respectively.
-
-(define scan-defines)
-(define unscan-defines)
-(define make-open-block)
-(define open-block?)
-(define open-block-components)
-
-(let ((open-block-tag (make-named-tag "OPEN-BLOCK"))
- (sequence-2-type (microcode-type 'SEQUENCE-2))
- (sequence-3-type (microcode-type 'SEQUENCE-3))
- (null-sequence '(NULL-SEQUENCE)))
-\f
-;;;; Scanning
-
-;;; This depends on the fact that the lambda abstraction will preserve
-;;; the order of the auxiliaries. That is, giving MAKE-LAMBDA a list
-;;; of auxiliaries will result in LAMBDA-COMPONENTS returning an
-;;; EQUAL? list.
-
-(set! scan-defines
-(named-lambda (scan-defines expression receiver)
- ((scan-loop expression receiver) '() '() null-sequence)))
-
-(define (scan-loop expression receiver)
- (cond ((primitive-type? sequence-2-type expression)
- (scan-loop (&pair-cdr expression)
- (scan-loop (&pair-car expression)
- receiver)))
- ((primitive-type? sequence-3-type expression)
- (let ((first (&triple-first expression)))
- (if (and (vector? first)
- (not (zero? (vector-length first)))
- (eq? (vector-ref first 0) open-block-tag))
- (lambda (names declarations body)
- (receiver (append (vector-ref first 1) names)
- (append (vector-ref first 2) declarations)
- (cons-sequence (&triple-third expression)
- body)))
- (scan-loop (&triple-third expression)
- (scan-loop (&triple-second expression)
- (scan-loop first
- receiver))))))
- ((definition? expression)
- (definition-components expression
- (lambda (name value)
- (lambda (names declarations body)
- (receiver (cons name names)
- declarations
- (cons-sequence (make-assignment name value)
- body))))))
- ((block-declaration? expression)
- (lambda (names declarations body)
- (receiver names
- (append (block-declaration-text expression)
- declarations)
- body)))
- (else
- (lambda (names declarations body)
- (receiver names
- declarations
- (cons-sequence expression body))))))
-
-(define (cons-sequence action sequence)
- (cond ((primitive-type? sequence-2-type sequence)
- (&typed-triple-cons sequence-3-type
- action
- (&pair-car sequence)
- (&pair-cdr sequence)))
- ((eq? sequence null-sequence)
- action)
- (else
- (&typed-pair-cons sequence-2-type action sequence))))
-\f
-(set! unscan-defines
-(named-lambda (unscan-defines names declarations body)
- (unscan-loop names body
- (lambda (names* body*)
- (if (not (null? names*))
- (error "Extraneous auxiliaries -- get a wizard"
- 'UNSCAN-DEFINES
- names*))
- (if (null? declarations)
- body*
- (&typed-pair-cons sequence-2-type
- (make-block-declaration declarations)
- body*))))))
-
-(define (unscan-loop names body receiver)
- (cond ((null? names) (receiver '() body))
- ((assignment? body)
- (assignment-components body
- (lambda (name value)
- (if (eq? name (car names))
- (receiver (cdr names)
- (make-definition name value))
- (receiver names
- body)))))
- ((primitive-type? sequence-2-type body)
- (unscan-loop names (&pair-car body)
- (lambda (names* body*)
- (unscan-loop names* (&pair-cdr body)
- (lambda (names** body**)
- (receiver names**
- (&typed-pair-cons sequence-2-type
- body*
- body**)))))))
- ((primitive-type? sequence-3-type body)
- (unscan-loop names (&triple-first body)
- (lambda (names* body*)
- (unscan-loop names* (&triple-second body)
- (lambda (names** body**)
- (unscan-loop names** (&triple-third body)
- (lambda (names*** body***)
- (receiver names***
- (&typed-triple-cons sequence-3-type
- body*
- body**
- body***)))))))))
- (else
- (receiver names
- body))))
-\f
-;;;; Open Block
-
-(set! make-open-block
-(named-lambda (make-open-block names declarations body)
- (if (and (null? names)
- (null? declarations))
- body
- (&typed-triple-cons
- sequence-3-type
- (vector open-block-tag names declarations)
- (if (null? names)
- '()
- (make-sequence
- (map (lambda (name)
- (make-definition name (make-unassigned-object)))
- names)))
- body))))
-
-
-(set! open-block?
-(named-lambda (open-block? object)
- (and (primitive-type? sequence-3-type object)
- (vector? (&triple-first object))
- (eq? (vector-ref (&triple-first object) 0) open-block-tag))))
-
-(set! open-block-components
-(named-lambda (open-block-components open-block receiver)
- (receiver (vector-ref (&triple-first open-block) 1)
- (vector-ref (&triple-first open-block) 2)
- (&triple-third open-block))))
-
-;;; end LET
-)
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 13.42 1987/03/17 18:52:47 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; SCODE Grab Bag
-
-(declare (usual-integrations))
-\f
-;;;; Constants
-
-(define scode-constant?
- (let ((type-vector (make-vector number-of-microcode-types false)))
- (for-each (lambda (name)
- (vector-set! type-vector (microcode-type name) true))
- '(NULL TRUE UNASSIGNED
- FIXNUM BIGNUM FLONUM
- CHARACTER STRING UNINTERNED-SYMBOL INTERNED-SYMBOL
- NON-MARKED-VECTOR VECTOR-1B VECTOR-16B
- PAIR TRIPLE VECTOR QUOTATION PRIMITIVE))
- (named-lambda (scode-constant? object)
- (vector-ref type-vector (primitive-type object)))))
-
-(define make-null)
-(define make-false)
-(define make-true)
-
-(let ()
- (define (make-constant-maker name)
- (let ((type (microcode-type name)))
- (lambda ()
- (primitive-set-type type 0))))
- (set! make-null (make-constant-maker 'NULL))
- (set! make-false (make-constant-maker 'FALSE))
- (set! make-true (make-constant-maker 'TRUE)))
-
-;;;; QUOTATION
-
-(define quotation?)
-(define make-quotation)
-
-(let ((type (microcode-type 'QUOTATION)))
- (set! quotation?
- (named-lambda (quotation? object)
- (primitive-type? type object)))
- (set! make-quotation
- (named-lambda (make-quotation expression)
- (&typed-singleton-cons type expression))))
-
-(define quotation-expression &singleton-element)
-\f
-;;;; SYMBOL
-
-(define symbol?)
-(define string->uninterned-symbol)
-(let ()
-
-(define utype
- (microcode-type 'UNINTERNED-SYMBOL))
-
-(define itype
- (microcode-type 'INTERNED-SYMBOL))
-
-(set! symbol?
-(named-lambda (symbol? object)
- (or (primitive-type? itype object)
- (primitive-type? utype object))))
-
-(set! string->uninterned-symbol
-(named-lambda (string->uninterned-symbol string)
- (&typed-pair-cons utype
- string
- (make-unbound-object))))
-
-)
-
-(define string->symbol
- (make-primitive-procedure 'STRING->SYMBOL))
-
-(define (symbol->string symbol)
- (make-object-safe (&pair-car symbol)))
-
-(define make-symbol string->uninterned-symbol)
-(define make-interned-symbol string->symbol)
-(define symbol-print-name symbol->string)
-
-(define (symbol-global-value symbol)
- (make-object-safe (&pair-cdr symbol)))
-
-(define (set-symbol-global-value! symbol value)
- (&pair-set-cdr! symbol
- ((if (object-dangerous? (&pair-cdr symbol))
- make-object-dangerous
- make-object-safe)
- value)))
-
-(define (make-named-tag name)
- (string->symbol (string-append "#[" name "]")))
-\f
-;;;; VARIABLE
-
-(define variable?)
-(define make-variable)
-
-(let ((type (microcode-type 'VARIABLE)))
- (set! variable?
- (named-lambda (variable? object)
- (primitive-type? type object)))
- (set! make-variable
- (named-lambda (make-variable name)
- (system-hunk3-cons type name (make-true) (make-null)))))
-
-(define variable-name system-hunk3-cxr0)
-
-(define (variable-components variable receiver)
- (receiver (variable-name variable)))
-
-;;;; DEFINITION
-
-(define definition?)
-(define make-definition)
-
-(let ((type (microcode-type 'DEFINITION)))
- (set! definition?
- (named-lambda (definition? object)
- (primitive-type? type object)))
- (set! make-definition
- (named-lambda (make-definition name value)
- (&typed-pair-cons type name value))))
-
-(define (definition-components definition receiver)
- (receiver (definition-name definition)
- (definition-value definition)))
-
-(define definition-name system-pair-car)
-(define set-definition-name! system-pair-set-car!)
-(define definition-value &pair-cdr)
-(define set-definition-value! &pair-set-cdr!)
-\f
-;;;; ASSIGNMENT
-
-(define assignment?)
-(define make-assignment-from-variable)
-
-(let ((type (microcode-type 'ASSIGNMENT)))
- (set! assignment?
- (named-lambda (assignment? object)
- (primitive-type? type object)))
- (set! make-assignment-from-variable
- (named-lambda (make-assignment-from-variable variable value)
- (&typed-pair-cons type variable value))))
-
-(define (assignment-components-with-variable assignment receiver)
- (receiver (assignment-variable assignment)
- (assignment-value assignment)))
-
-(define assignment-variable system-pair-car)
-(define set-assignment-variable! system-pair-set-car!)
-(define assignment-value &pair-cdr)
-(define set-assignment-value! &pair-set-cdr!)
-
-(define (make-assignment name value)
- (make-assignment-from-variable (make-variable name) value))
-
-(define (assignment-components assignment receiver)
- (assignment-components-with-variable assignment
- (lambda (variable value)
- (receiver (variable-name variable) value))))
-
-(define (assignment-name assignment)
- (variable-name (assignment-variable assignment)))
-\f
-;;;; COMMENT
-
-(define comment?)
-(define make-comment)
-
-(let ((type (microcode-type 'COMMENT)))
- (set! comment?
- (named-lambda (comment? object)
- (primitive-type? type object)))
- (set! make-comment
- (named-lambda (make-comment text expression)
- (&typed-pair-cons type expression text))))
-
-(define (comment-components comment receiver)
- (receiver (comment-text comment)
- (comment-expression comment)))
-
-(define comment-text &pair-cdr)
-(define set-comment-text! &pair-set-cdr!)
-(define comment-expression &pair-car)
-(define set-comment-expression! &pair-set-car!)
-\f
-;;;; DECLARATION
-
-(define declaration?)
-(define make-declaration)
-
-(let ((tag (make-named-tag "DECLARATION")))
- (set! declaration?
- (named-lambda (declaration? object)
- (and (comment? object)
- (let ((text (comment-text object)))
- (and (pair? text)
- (eq? (car text) tag))))))
- (set! make-declaration
- (named-lambda (make-declaration text expression)
- (make-comment (cons tag text) expression))))
-
-(define (declaration-components declaration receiver)
- (comment-components declaration
- (lambda (text expression)
- (receiver (cdr text) expression))))
-
-(define (declaration-text tagged-comment)
- (cdr (comment-text tagged-comment)))
-
-(define (set-declaration-text! tagged-comment new-text)
- (set-cdr! (comment-text tagged-comment) new-text))
-
-(define declaration-expression
- comment-expression)
-
-(define set-declaration-expression!
- set-comment-expression!)
-
-(define make-block-declaration)
-(define block-declaration?)
-(let ()
-
-(define tag
- (make-named-tag "Block Declaration"))
-
-(set! make-block-declaration
-(named-lambda (make-block-declaration text)
- (cons tag text)))
-
-(set! block-declaration?
-(named-lambda (block-declaration? object)
- (and (pair? object) (eq? (car object) tag))))
-
-)
-
-(define block-declaration-text
- cdr)
-\f
-;;;; THE-ENVIRONMENT
-
-(define the-environment?)
-(define make-the-environment)
-
-(let ((type (microcode-type 'THE-ENVIRONMENT)))
- (set! the-environment?
- (named-lambda (the-environment? object)
- (primitive-type? type object)))
- (set! make-the-environment
- (named-lambda (make-the-environment)
- (primitive-set-type type 0))))
-
-;;;; ACCESS
-
-(define access?)
-(define make-access)
-
-(let ((type (microcode-type 'ACCESS)))
- (set! access?
- (named-lambda (access? object)
- (primitive-type? type object)))
- (set! make-access
- (named-lambda (make-access environment name)
- (&typed-pair-cons type environment name))))
-
-(define (access-components access receiver)
- (receiver (access-environment access)
- (access-name access)))
-
-(define access-environment &pair-car)
-(define access-name system-pair-cdr)
-
-;;;; IN-PACKAGE
-
-(define in-package?)
-(define make-in-package)
-
-(let ((type (microcode-type 'IN-PACKAGE)))
- (set! in-package?
- (named-lambda (in-package? object)
- (primitive-type? type object)))
- (set! make-in-package
- (named-lambda (make-in-package environment expression)
- (&typed-pair-cons type environment expression))))
-
-(define (in-package-components in-package receiver)
- (receiver (in-package-environment in-package)
- (in-package-expression in-package)))
-
-(define in-package-environment &pair-car)
-(define in-package-expression &pair-cdr)
-\f
-;;;; DELAY
-
-(define delay?)
-(define make-delay)
-
-(let ((type (microcode-type 'DELAY)))
- (set! delay?
- (named-lambda (delay? object)
- (primitive-type? type object)))
- (set! make-delay
- (named-lambda (make-delay expression)
- (&typed-singleton-cons type expression))))
-
-(define delay-expression &singleton-element)
-
-(define (delay-components delay receiver)
- (receiver (delay-expression delay)))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 13.42 1987/03/17 18:52:59 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; SCODE Combinator Abstractions
-
-(declare (usual-integrations))
-\f
-;;;; SEQUENCE
-
-(define sequence?)
-(define make-sequence)
-(define sequence-actions)
-(let ()
-
-(define type-2
- (microcode-type 'SEQUENCE-2))
-
-(define type-3
- (microcode-type 'SEQUENCE-3))
-
-(set! sequence?
-(named-lambda (sequence? object)
- (or (primitive-type? type-2 object)
- (primitive-type? type-3 object))))
-
-(set! make-sequence
-(lambda (actions)
- (if (null? actions)
- (error "MAKE-SEQUENCE: No actions")
- (actions->sequence actions))))
-
-(define (actions->sequence actions)
- (cond ((null? (cdr actions))
- (car actions))
- ((null? (cddr actions))
- (&typed-pair-cons type-2
- (car actions)
- (cadr actions)))
- (else
- (&typed-triple-cons type-3
- (car actions)
- (cadr actions)
- (actions->sequence (cddr actions))))))
-
-(set! sequence-actions
-(named-lambda (sequence-actions sequence)
- (cond ((primitive-type? type-2 sequence)
- (append! (sequence-actions (&pair-car sequence))
- (sequence-actions (&pair-cdr sequence))))
- ((primitive-type? type-3 sequence)
- (append! (sequence-actions (&triple-first sequence))
- (sequence-actions (&triple-second sequence))
- (sequence-actions (&triple-third sequence))))
- (else
- (list sequence)))))
-
-)
-
-(define (sequence-components sequence receiver)
- (receiver (sequence-actions sequence)))
-\f
-;;;; CONDITIONAL
-
-(define conditional?)
-(define make-conditional)
-(let ()
-
-(define type
- (microcode-type 'CONDITIONAL))
-
-(set! conditional?
-(named-lambda (conditional? object)
- (primitive-type? type object)))
-
-(set! make-conditional
-(named-lambda (make-conditional predicate consequent alternative)
- (if (combination? predicate)
- (combination-components predicate
- (lambda (operator operands)
- (if (eq? operator not)
- (make-conditional (first operands)
- alternative
- consequent)
- (&typed-triple-cons type
- predicate
- consequent
- alternative))))
- (&typed-triple-cons type predicate consequent alternative))))
-
-)
-
-(define (conditional-components conditional receiver)
- (receiver (conditional-predicate conditional)
- (conditional-consequent conditional)
- (conditional-alternative conditional)))
-
-(define conditional-predicate &triple-first)
-(define conditional-consequent &triple-second)
-(define conditional-alternative &triple-third)
-\f
-;;;; DISJUNCTION
-
-(define disjunction?)
-(define make-disjunction)
-(let ()
-
-(define type
- (microcode-type 'DISJUNCTION))
-
-(set! disjunction?
-(named-lambda (disjunction? object)
- (primitive-type? type object)))
-
-(set! make-disjunction
-(named-lambda (make-disjunction predicate alternative)
- (if (combination? predicate)
- (combination-components predicate
- (lambda (operator operands)
- (if (eq? operator not)
- (make-conditional (first operands) alternative true)
- (&typed-pair-cons type predicate alternative))))
- (&typed-pair-cons type predicate alternative))))
-
-)
-
-(define (disjunction-components disjunction receiver)
- (receiver (disjunction-predicate disjunction)
- (disjunction-alternative disjunction)))
-
-(define disjunction-predicate &pair-car)
-(define disjunction-alternative &pair-cdr)
-\f
-;;;; COMBINATION
-
-(define combination?)
-(define make-combination)
-(define combination-size)
-(define combination-components)
-(define combination-operator)
-(define combination-operands)
-(let ()
-
-(define type-1 (microcode-type 'COMBINATION-1))
-(define type-2 (microcode-type 'COMBINATION-2))
-(define type-N (microcode-type 'COMBINATION))
-(define p-type (microcode-type 'PRIMITIVE))
-(define p-type-0 (microcode-type 'PRIMITIVE-COMBINATION-0))
-(define p-type-1 (microcode-type 'PRIMITIVE-COMBINATION-1))
-(define p-type-2 (microcode-type 'PRIMITIVE-COMBINATION-2))
-(define p-type-3 (microcode-type 'PRIMITIVE-COMBINATION-3))
-
-(define (primitive-procedure? object)
- (primitive-type? p-type object))
-
-(set! combination?
-(named-lambda (combination? object)
- (or (primitive-type? type-1 object)
- (primitive-type? type-2 object)
- (primitive-type? type-N object)
- (primitive-type? p-type-0 object)
- (primitive-type? p-type-1 object)
- (primitive-type? p-type-2 object)
- (primitive-type? p-type-3 object))))
-\f
-(set! make-combination
-(lambda (operator operands)
- (cond ((and (memq operator constant-folding-operators)
- (all-constants? operands))
- (apply operator operands))
- ((null? operands)
- (if (and (primitive-procedure? operator)
- (= (primitive-procedure-arity operator) 0))
- (primitive-set-type p-type-0 operator)
- (&typed-vector-cons type-N (cons operator '()))))
- ((null? (cdr operands))
- (&typed-pair-cons
- (if (and (primitive-procedure? operator)
- (= (primitive-procedure-arity operator) 1))
- p-type-1
- type-1)
- operator
- (car operands)))
- ((null? (cddr operands))
- (&typed-triple-cons
- (if (and (primitive-procedure? operator)
- (= (primitive-procedure-arity operator) 2))
- p-type-2
- type-2)
- operator
- (car operands)
- (cadr operands)))
- (else
- (&typed-vector-cons
- (if (and (null? (cdddr operands))
- (primitive-procedure? operator)
- (= (primitive-procedure-arity operator) 3))
- p-type-3
- type-N)
- (cons operator operands))))))
-
-(define constant-folding-operators
- (map make-primitive-procedure
- '(PRIMITIVE-TYPE
- CAR CDR VECTOR-LENGTH VECTOR-REF
- &+ &- &* &/ INTEGER-DIVIDE 1+ -1+
- TRUNCATE ROUND FLOOR CEILING
- SQRT EXP LOG SIN COS &ATAN)))
-
-(define (all-constants? expressions)
- (or (null? expressions)
- (and (scode-constant? (car expressions))
- (all-constants? (cdr expressions)))))
-\f
-(set! combination-size
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- 1)
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- 2)
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- 3)
- ((primitive-type? p-type-3 combination)
- 4)
- ((primitive-type? type-N combination)
- (&vector-size combination))
- (else
- (error "Not a combination -- COMBINATION-SIZE" combination)))))
-
-(set! combination-operator
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- (primitive-set-type p-type combination))
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (&pair-car combination))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (&triple-first combination))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (&vector-ref combination 0))
- (else
- (error "Not a combination -- COMBINATION-OPERATOR"
- combination)))))
-
-(set! combination-operands
-(lambda (combination)
- (cond ((primitive-type? p-type-0 combination)
- '())
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (list (&pair-cdr combination)))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (list (&triple-second combination)
- (&triple-third combination)))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (&subvector-to-list combination 1 (&vector-size combination)))
- (else
- (error "Not a combination -- COMBINATION-OPERANDS"
- combination)))))
-\f
-(set! combination-components
-(lambda (combination receiver)
- (cond ((primitive-type? p-type-0 combination)
- (receiver (primitive-set-type p-type combination)
- '()))
- ((or (primitive-type? type-1 combination)
- (primitive-type? p-type-1 combination))
- (receiver (&pair-car combination)
- (list (&pair-cdr combination))))
- ((or (primitive-type? type-2 combination)
- (primitive-type? p-type-2 combination))
- (receiver (&triple-first combination)
- (list (&triple-second combination)
- (&triple-third combination))))
- ((or (primitive-type? p-type-3 combination)
- (primitive-type? type-N combination))
- (receiver (&vector-ref combination 0)
- (&subvector-to-list combination 1
- (&vector-size combination))))
- (else
- (error "Not a combination -- COMBINATION-COMPONENTS"
- combination)))))
-
-)
-\f
-;;;; UNASSIGNED?
-
-(define unassigned??)
-(define make-unassigned?)
-(define unbound??)
-(define make-unbound?)
-(let ()
-
-(define ((envop-characteristic envop) object)
- (and (combination? object)
- (combination-components object
- (lambda (operator operands)
- (and (eq? operator envop)
- (the-environment? (first operands))
- (symbol? (second operands)))))))
-
-(define ((envop-maker envop) name)
- (make-combination envop
- (list (make-the-environment) name)))
-
-(set! unassigned??
- (envop-characteristic lexical-unassigned?))
-
-(set! make-unassigned?
- (envop-maker lexical-unassigned?))
-
-(set! unbound??
- (envop-characteristic lexical-unbound?))
-
-(set! make-unbound?
- (envop-maker lexical-unbound?))
-
-)
-
-(define (unassigned?-name unassigned?)
- (second (combination-operands unassigned?)))
-
-(define (unassigned?-components unassigned? receiver)
- (receiver (unassigned?-name unassigned?)))
-
-(define unbound?-name unassigned?-name)
-(define unbound?-components unassigned?-components)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sdata.scm,v 13.42 1987/04/03 00:52:12 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Abstract Data Field
-
-(declare (usual-integrations))
-\f
-(define unbound-object?)
-(define make-unbound-object)
-
-(define unassigned-object?)
-(define make-unassigned-object)
-
-(define &typed-singleton-cons)
-(define &singleton-element)
-(define &singleton-set-element!)
-
-(define &typed-pair-cons)
-(define &pair-car)
-(define &pair-set-car!)
-(define &pair-cdr)
-(define &pair-set-cdr!)
-
-(define &typed-triple-cons)
-(define &triple-first)
-(define &triple-set-first!)
-(define &triple-second)
-(define &triple-set-second!)
-(define &triple-third)
-(define &triple-set-third!)
-
-(define &typed-vector-cons)
-(define &list-to-vector)
-(define &vector-size)
-(define &vector-ref)
-(define &vector-to-list)
-(define &subvector-to-list)
-\f
-(let ((&unbound-object '(&UNBOUND-OBJECT))
- (&unbound-datum 2)
- (&unassigned-object '(&UNASSIGNED-OBJECT))
- (&unassigned-datum 0)
- (&unassigned-type (microcode-type 'UNASSIGNED))
- (&make-object (make-primitive-procedure '&MAKE-OBJECT))
- (hunk3-cons (make-primitive-procedure 'HUNK3-CONS)))
-
- (define (map-unassigned object)
- (cond ((eq? object &unbound-object)
- (&make-object &unassigned-type &unbound-datum))
- ((eq? object &unassigned-object)
- (&make-object &unassigned-type &unassigned-datum))
- (else object)))
-
- ;; This is no longer really right, given the other traps.
- (define (map-from-unassigned datum)
- (if (eq? datum &unassigned-datum) ;**** cheat for speed.
- &unassigned-object
- &unbound-object))
-
- (define (map-unassigned-list list)
- (if (null? list)
- '()
- (cons (map-unassigned (car list))
- (map-unassigned-list (cdr list)))))
-
-(set! make-unbound-object
- (lambda ()
- &unbound-object))
-
-(set! unbound-object?
- (lambda (object)
- (eq? object &unbound-object)))
-
-(set! make-unassigned-object
- (lambda ()
- &unassigned-object))
-
-(set! unassigned-object?
- (let ((microcode-unassigned-object
- (vector-ref (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'NON-OBJECT))))
- (lambda (object)
- (or (eq? object &unassigned-object)
- (eq? object microcode-unassigned-object)))))
-
-(set! &typed-singleton-cons
- (lambda (type element)
- (system-pair-cons type
- (map-unassigned element)
- #!NULL)))
-
-(set! &singleton-element
- (lambda (singleton)
- (if (primitive-type? &unassigned-type (system-pair-car singleton))
- (map-from-unassigned (primitive-datum (system-pair-car singleton)))
- (system-pair-car singleton))))
-
-(set! &singleton-set-element!
- (lambda (singleton new-element)
- (system-pair-set-car! singleton (map-unassigned new-element))))
-\f
-(set! &typed-pair-cons
- (lambda (type car cdr)
- (system-pair-cons type
- (map-unassigned car)
- (map-unassigned cdr))))
-
-(set! &pair-car
- (lambda (pair)
- (if (primitive-type? &unassigned-type (system-pair-car pair))
- (map-from-unassigned (primitive-datum (system-pair-car pair)))
- (system-pair-car pair))))
-
-(set! &pair-set-car!
- (lambda (pair new-car)
- (system-pair-set-car! pair (map-unassigned new-car))))
-
-(set! &pair-cdr
- (lambda (pair)
- (if (primitive-type? &unassigned-type (system-pair-cdr pair))
- (map-from-unassigned (primitive-datum (system-pair-cdr pair)))
- (system-pair-cdr pair))))
-
-(set! &pair-set-cdr!
- (lambda (pair new-cdr)
- (system-pair-set-cdr! pair (map-unassigned new-cdr))))
-
-(set! &typed-triple-cons
- (lambda (type first second third)
- (primitive-set-type type
- (hunk3-cons (map-unassigned first)
- (map-unassigned second)
- (map-unassigned third)))))
-
-(set! &triple-first
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr0 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr0 triple)))
- (system-hunk3-cxr0 triple))))
-
-(set! &triple-set-first!
- (lambda (triple new-first)
- (system-hunk3-set-cxr0! triple (map-unassigned new-first))))
-
-(set! &triple-second
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr1 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr1 triple)))
- (system-hunk3-cxr1 triple))))
-
-(set! &triple-set-second!
- (lambda (triple new-second)
- (system-hunk3-set-cxr0! triple (map-unassigned new-second))))
-
-(set! &triple-third
- (lambda (triple)
- (if (primitive-type? &unassigned-type (system-hunk3-cxr2 triple))
- (map-from-unassigned (primitive-datum (system-hunk3-cxr2 triple)))
- (system-hunk3-cxr2 triple))))
-
-(set! &triple-set-third!
- (lambda (triple new-third)
- (system-hunk3-set-cxr0! triple (map-unassigned new-third))))
-\f
-(set! &typed-vector-cons
- (lambda (type elements)
- (system-list-to-vector type (map-unassigned-list elements))))
-
-(set! &list-to-vector
- list->vector)
-
-(set! &vector-size
- system-vector-size)
-
-(set! &vector-ref
- (lambda (vector index)
- (if (primitive-type? &unassigned-type (system-vector-ref vector index))
- (map-from-unassigned
- (primitive-datum (system-vector-ref vector index)))
- (system-vector-ref vector index))))
-
-(set! &vector-to-list
- (lambda (vector)
- (&subvector-to-list vector 0 (system-vector-size vector))))
-
-(set! &subvector-to-list
- (lambda (vector start stop)
- (let loop ((sublist (system-subvector-to-list vector start stop)))
- (if (null? sublist)
- '()
- (cons (if (primitive-type? &unassigned-type (car sublist))
- (map-from-unassigned (primitive-datum (car sublist)))
- (car sublist))
- (loop (cdr sublist)))))))
-
-)
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 13.41 1987/01/23 00:19:51 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Simple File Operations
-
-(declare (usual-integrations))
-\f
-(define copy-file
- (let ((p-copy-file (make-primitive-procedure 'COPY-FILE)))
- (named-lambda (copy-file from to)
- (p-copy-file (canonicalize-input-filename from)
- (canonicalize-output-filename to)))))
-
-(define rename-file
- (let ((p-rename-file (make-primitive-procedure 'RENAME-FILE)))
- (named-lambda (rename-file from to)
- (p-rename-file (canonicalize-input-filename from)
- (canonicalize-output-filename to)))))
-
-(define delete-file
- (let ((p-delete-file (make-primitive-procedure 'REMOVE-FILE)))
- (named-lambda (delete-file name)
- (p-delete-file (canonicalize-input-filename name)))))
-
-(define file-exists?
- (let ((p-file-exists? (make-primitive-procedure 'FILE-EXISTS?)))
- (named-lambda (file-exists? name)
- (let ((pathname (->pathname name)))
- (if (eq? 'NEWEST (pathname-version pathname))
- (pathname-newest pathname)
- (p-file-exists?
- (pathname->string (pathname->absolute-pathname pathname))))))))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/stream.scm,v 13.41 1987/01/23 00:20:30 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Stream Utilities
-
-(declare (usual-integrations))
-\f
-;;;; General Streams
-
-(define (nth-stream n s)
- (cond ((empty-stream? s)
- (error "Empty stream -- NTH-STREAM" n))
- ((= n 0)
- (head s))
- (else
- (nth-stream (- n 1) (tail s)))))
-
-(define (accumulate combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (accumulate combiner
- initial-value
- (tail stream)))))
-
-(define (filter pred stream)
- (cond ((empty-stream? stream)
- the-empty-stream)
- ((pred (head stream))
- (cons-stream (head stream)
- (filter pred (tail stream))))
- (else
- (filter pred (tail stream)))))
-
-(define (map-stream proc stream)
- (if (empty-stream? stream)
- the-empty-stream
- (cons-stream (proc (head stream))
- (map-stream proc (tail stream)))))
-
-(define (map-stream-2 proc s1 s2)
- (if (or (empty-stream? s1)
- (empty-stream? s2))
- the-empty-stream
- (cons-stream (proc (head s1) (head s2))
- (map-stream-2 proc (tail s1) (tail s2)))))
-
-(define (append-streams s1 s2)
- (if (empty-stream? s1)
- s2
- (cons-stream (head s1)
- (append-streams (tail s1) s2))))
-
-(define (enumerate-fringe tree)
- (if (pair? tree)
- (append-streams (enumerate-fringe (car tree))
- (enumerate-fringe (cdr tree)))
- (cons-stream tree the-empty-stream)))
-\f
-;;;; Numeric Streams
-
-(define (add-streams s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (cons-stream (+ (head s1) (head s2))
- (add-streams (tail s1) (tail s2))))))
-
-(define (scale-stream c s)
- (map-stream (lambda (x) (* c x)) s))
-
-(define (enumerate-interval n1 n2)
- (if (> n1 n2)
- the-empty-stream
- (cons-stream n1 (enumerate-interval (1+ n1) n2))))
-
-(define (integers-from n)
- (cons-stream n (integers-from (1+ n))))
-
-(define integers
- (integers-from 0))
-\f
-;;;; Some Hairier Stuff
-
-(define (merge s1 s2)
- (cond ((empty-stream? s1) s2)
- ((empty-stream? s2) s1)
- (else
- (let ((h1 (head s1))
- (h2 (head s2)))
- (cond ((< h1 h2)
- (cons-stream h1
- (merge (tail s1)
- s2)))
- ((> h1 h2)
- (cons-stream h2
- (merge s1
- (tail s2))))
- (else
- (cons-stream h1
- (merge (tail s1)
- (tail s2)))))))))
-\f
-;;;; Printing
-
-(define print-stream
- (let ()
- (define (iter s)
- (if (empty-stream? s)
- (write-string "}")
- (begin (write-string " ")
- (write (head s))
- (iter (tail s)))))
- (lambda (s)
- (newline)
- (write-string "{")
- (if (empty-stream? s)
- (write-string "}")
- (begin (write (head s))
- (iter (tail s)))))))
-\f
-;;;; Support for COLLECT
-
-(define (flatmap f s)
- (flatten (map-stream f s)))
-
-(define (flatten stream)
- (accumulate-delayed interleave-delayed
- the-empty-stream
- stream))
-
-(define (accumulate-delayed combiner initial-value stream)
- (if (empty-stream? stream)
- initial-value
- (combiner (head stream)
- (delay (accumulate-delayed combiner
- initial-value
- (tail stream))))))
-
-(define (interleave-delayed s1 delayed-s2)
- (if (empty-stream? s1)
- (force delayed-s2)
- (cons-stream (head s1)
- (interleave-delayed (force delayed-s2)
- (delay (tail s1))))))
-
-(define ((spread-tuple procedure) tuple)
- (apply procedure tuple))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/string.scm,v 13.41 1987/01/23 00:20:37 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Character String Operations
-
-(declare (usual-integrations))
-\f
-;;;; Primitives
-
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))
-
- (define-primitives
- string-allocate string? string-ref string-set!
- string-length string-maximum-length set-string-length!
- substring=? substring-ci=? substring<?
- substring-move-right! substring-move-left!
- substring-find-next-char-in-set
- substring-find-previous-char-in-set
- substring-match-forward substring-match-backward
- substring-match-forward-ci substring-match-backward-ci
- substring-upcase! substring-downcase! string-hash
-
- vector-8b-ref vector-8b-set! vector-8b-fill!
- vector-8b-find-next-char vector-8b-find-previous-char
- vector-8b-find-next-char-ci vector-8b-find-previous-char-ci)))
-
-;;; Character Covers
-
-(define (substring-fill! string start end char)
- (vector-8b-fill! string start end (char->ascii char)))
-
-(define (substring-find-next-char string start end char)
- (vector-8b-find-next-char string start end (char->ascii char)))
-
-(define (substring-find-previous-char string start end char)
- (vector-8b-find-previous-char string start end (char->ascii char)))
-
-(define (substring-find-next-char-ci string start end char)
- (vector-8b-find-next-char-ci string start end (char->ascii char)))
-
-(define (substring-find-previous-char-ci string start end char)
- (vector-8b-find-previous-char-ci string start end (char->ascii char)))
-
-;;; Special, not implemented in microcode.
-
-(define (substring-ci<? string1 start1 end1 string2 start2 end2)
- (let ((match (substring-match-forward-ci string1 start1 end1
- string2 start2 end2))
- (len1 (- end1 start1))
- (len2 (- end2 start2)))
- (and (not (= match len2))
- (or (= match len1)
- (char-ci<? (string-ref string1 (+ match start1))
- (string-ref string2 (+ match start2)))))))
-\f
-;;; Substring Covers
-
-(define (string=? string1 string2)
- (substring=? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string-ci=? string1 string2)
- (substring-ci=? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string<? string1 string2)
- (substring<? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string-ci<? string1 string2)
- (substring-ci<? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string>? string1 string2)
- (substring<? string2 0 (string-length string2)
- string1 0 (string-length string1)))
-
-(define (string-ci>? string1 string2)
- (substring-ci<? string2 0 (string-length string2)
- string1 0 (string-length string1)))
-
-(define (string>=? string1 string2)
- (not (substring<? string1 0 (string-length string1)
- string2 0 (string-length string2))))
-
-(define (string-ci>=? string1 string2)
- (not (substring-ci<? string1 0 (string-length string1)
- string2 0 (string-length string2))))
-
-(define (string<=? string1 string2)
- (not (substring<? string2 0 (string-length string2)
- string1 0 (string-length string1))))
-
-(define (string-ci<=? string1 string2)
- (not (substring-ci<? string2 0 (string-length string2)
- string1 0 (string-length string1))))
-\f
-(define (string-fill! string char)
- (substring-fill! string 0 (string-length string) char))
-
-(define (string-find-next-char string char)
- (substring-find-next-char string 0 (string-length string) char))
-
-(define (string-find-previous-char string char)
- (substring-find-previous-char string 0 (string-length string) char))
-
-(define (string-find-next-char-ci string char)
- (substring-find-next-char-ci string 0 (string-length string) char))
-
-(define (string-find-previous-char-ci string char)
- (substring-find-previous-char-ci string 0 (string-length string) char))
-
-(define (string-find-next-char-in-set string char-set)
- (substring-find-next-char-in-set string 0 (string-length string) char-set))
-
-(define (string-find-previous-char-in-set string char-set)
- (substring-find-previous-char-in-set string 0 (string-length string)
- char-set))
-
-(define (string-match-forward string1 string2)
- (substring-match-forward string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string-match-backward string1 string2)
- (substring-match-backward string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string-match-forward-ci string1 string2)
- (substring-match-forward-ci string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (string-match-backward-ci string1 string2)
- (substring-match-backward-ci string1 0 (string-length string1)
- string2 0 (string-length string2)))
-\f
-;;;; Basic Operations
-
-(define (make-string length #!optional char)
- (if (unassigned? char)
- (string-allocate length)
- (let ((result (string-allocate length)))
- (substring-fill! result 0 length char)
- result)))
-
-(define (string-null? string)
- (zero? (string-length string)))
-
-(define (substring string start end)
- (let ((result (string-allocate (- end start))))
- (substring-move-right! string start end result 0)
- result))
-
-(define (list->string chars)
- (let ((result (string-allocate (length chars))))
- (define (loop index chars)
- (if (null? chars)
- result
- (begin (string-set! result index (car chars))
- (loop (1+ index) (cdr chars)))))
- (loop 0 chars)))
-
-(define (char->string . chars)
- (list->string chars))
-
-(define (string->list string)
- (substring->list string 0 (string-length string)))
-
-(define (substring->list string start end)
- (define (loop index)
- (if (= index end)
- '()
- (cons (string-ref string index)
- (loop (1+ index)))))
- (loop start))
-
-(define (string-copy string)
- (let ((size (string-length string)))
- (let ((result (string-allocate size)))
- (substring-move-right! string 0 size result 0)
- result)))
-
-(define (string-append . strings)
- (define (count strings)
- (if (null? strings)
- 0
- (+ (string-length (car strings))
- (count (cdr strings)))))
-
- (let ((result (string-allocate (count strings))))
- (define (move strings index)
- (if (null? strings)
- result
- (let ((size (string-length (car strings))))
- (substring-move-right! (car strings) 0 size result index)
- (move (cdr strings) (+ index size)))))
-
- (move strings 0)))
-\f
-;;;; Case
-
-(define (string-upper-case? string)
- (substring-upper-case? string 0 (string-length string)))
-
-(define (substring-upper-case? string start end)
- (define (find-upper start)
- (and (not (= start end))
- ((if (char-upper-case? (string-ref string start))
- search-rest
- find-upper)
- (1+ start))))
- (define (search-rest start)
- (or (= start end)
- (and (not (char-lower-case? (string-ref string start)))
- (search-rest (1+ start)))))
- (find-upper start))
-
-(define (string-upcase string)
- (let ((string (string-copy string)))
- (string-upcase! string)
- string))
-
-(define (string-upcase! string)
- (substring-upcase! string 0 (string-length string)))
-
-(define (string-lower-case? string)
- (substring-lower-case? string 0 (string-length string)))
-
-(define (substring-lower-case? string start end)
- (define (find-lower start)
- (and (not (= start end))
- ((if (char-lower-case? (string-ref string start))
- search-rest
- find-lower)
- (1+ start))))
- (define (search-rest start)
- (or (= start end)
- (and (not (char-upper-case? (string-ref string start)))
- (search-rest (1+ start)))))
- (find-lower start))
-
-(define (string-downcase string)
- (let ((string (string-copy string)))
- (string-downcase! string)
- string))
-
-(define (string-downcase! string)
- (substring-downcase! string 0 (string-length string)))
-\f
-(define (string-capitalized? string)
- (substring-capitalized? string 0 (string-length string)))
-
-(define (substring-capitalized? string start end)
- (and (not (= start end))
- (char-upper-case? (string-ref string 0))
- (substring-lower-case? string (1+ start) end)))
-
-(define (string-capitalize string)
- (let ((string (string-copy string)))
- (string-capitalize! string)
- string))
-
-(define (string-capitalize! string)
- (let ((length (string-length string)))
- (if (zero? length) (error "String must have non-zero length" string))
- (substring-upcase! string 0 1)
- (substring-downcase! string 1 length)))
-\f
-;;;; Replace
-
-(define (string-replace string char1 char2)
- (let ((string (string-copy string)))
- (string-replace! string char1 char2)
- string))
-
-(define (substring-replace string start end char1 char2)
- (let ((string (string-copy string)))
- (substring-replace! string start end char1 char2)
- string))
-
-(define (string-replace! string char1 char2)
- (substring-replace! string 0 (string-length string) char1 char2))
-
-(define (substring-replace! string start end char1 char2)
- (define (loop start)
- (let ((index (substring-find-next-char string start end char1)))
- (if index
- (begin (string-set! string index char2)
- (loop (1+ index))))))
- (loop start))
-\f
-;;;; Compare
-
-(define (string-compare string1 string2 if= if< if>)
- (let ((size1 (string-length string1))
- (size2 (string-length string2)))
- (let ((match (substring-match-forward string1 0 size1 string2 0 size2)))
- ((if (= match size1)
- (if (= match size2) if= if<)
- (if (= match size2) if>
- (if (char<? (string-ref string1 match)
- (string-ref string2 match))
- if< if>)))))))
-
-(define (string-prefix? string1 string2)
- (substring-prefix? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (substring-prefix? string1 start1 end1 string2 start2 end2)
- (and (<= (- end1 start1) (- end2 start2))
- (= (substring-match-forward string1 start1 end1
- string2 start2 end2)
- end1)))
-
-(define (string-compare-ci string1 string2 if= if< if>)
- (let ((size1 (string-length string1))
- (size2 (string-length string2)))
- (let ((match (substring-match-forward-ci string1 0 size1 string2 0 size2)))
- ((if (= match size1)
- (if (= match size2) if= if<)
- (if (= match size2) if>
- (if (char-ci<? (string-ref string1 match)
- (string-ref string2 match))
- if< if>)))))))
-
-(define (string-prefix-ci? string1 string2)
- (substring-prefix-ci? string1 0 (string-length string1)
- string2 0 (string-length string2)))
-
-(define (substring-prefix-ci? string1 start1 end1 string2 start2 end2)
- (and (<= (- end1 start1) (- end2 start2))
- (= (substring-match-forward-ci string1 start1 end1
- string2 start2 end2)
- end1)))
-\f
-;;;; Trim/Pad
-
-(define (string-trim-left string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
- (let ((index (string-find-next-char-in-set string char-set))
- (length (string-length string)))
- (if (not index)
- ""
- (substring string index length))))
-
-(define (string-trim-right string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
- (let ((index (string-find-previous-char-in-set string char-set)))
- (if (not index)
- ""
- (substring string 0 (1+ index)))))
-
-(define (string-trim string #!optional char-set)
- (if (unassigned? char-set) (set! char-set char-set:not-whitespace))
- (let ((index (string-find-next-char-in-set string char-set)))
- (if (not index)
- ""
- (substring string index
- (1+ (string-find-previous-char-in-set string char-set))))))
-
-(define (string-pad-right string n #!optional char)
- (if (unassigned? char) (set! char #\Space))
- (let ((length (string-length string)))
- (if (= length n)
- string
- (let ((result (string-allocate n)))
- (if (> length n)
- (substring-move-right! string 0 n result 0)
- (begin (substring-move-right! string 0 length result 0)
- (substring-fill! result length n char)))
- result))))
-
-(define (string-pad-left string n #!optional char)
- (if (unassigned? char) (set! char #\Space))
- (let ((length (string-length string)))
- (if (= length n)
- string
- (let ((result (string-allocate n))
- (i (- n length)))
- (if (negative? i)
- (substring-move-right! string 0 n result 0)
- (begin (substring-fill! result 0 i char)
- (substring-move-right! string 0 length result i)))
- result))))
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 13.44 1987/04/03 00:52:43 jinx Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; SYNTAX: S-Expressions -> SCODE
-
-(declare (usual-integrations))
-\f
-(define lambda-tag:unnamed
- (make-named-tag "UNNAMED-PROCEDURE"))
-
-(define *fluid-let-type*
- 'SHALLOW)
-
-(define lambda-tag:shallow-fluid-let
- (make-named-tag "SHALLOW-FLUID-LET-PROCEDURE"))
-
-(define lambda-tag:deep-fluid-let
- (make-named-tag "DEEP-FLUID-LET-PROCEDURE"))
-
-(define lambda-tag:common-lisp-fluid-let
- (make-named-tag "COMMON-LISP-FLUID-LET-PROCEDURE"))
-
-(define lambda-tag:let
- (make-named-tag "LET-PROCEDURE"))
-
-(define lambda-tag:make-environment
- (make-named-tag "MAKE-ENVIRONMENT-PROCEDURE"))
-
-(define syntax)
-(define syntax*)
-(define macro-spreader)
-
-(define enable-scan-defines!)
-(define with-scan-defines-enabled)
-(define disable-scan-defines!)
-(define with-scan-defines-disabled)
-
-;; Enable shallow vs fluid binding for FLUID-LET
-(define shallow-fluid-let!)
-(define deep-fluid-let!)
-(define common-lisp-fluid-let!)
-
-(define system-global-syntax-table)
-(define syntax-table?)
-(define make-syntax-table)
-(define extend-syntax-table)
-(define copy-syntax-table)
-(define syntax-table-ref)
-(define syntax-table-define)
-(define syntax-table-shadow)
-(define syntax-table-undefine)
-
-(define syntaxer-package)
-(let ((external-make-sequence make-sequence)
- (external-make-lambda make-lambda))
-(set! syntaxer-package (the-environment))
-\f
-;;;; Dispatch Point
-
-(define (syntax-expression expression)
- (cond ((pair? expression)
- (let ((quantum (syntax-table-ref syntax-table (car expression))))
- (if quantum
- (fluid-let ((saved-keyword (car expression)))
- (quantum expression))
- (make-combination (syntax-expression (car expression))
- (syntax-expressions (cdr expression))))))
- ((symbol? expression)
- (make-variable expression))
- (else
- expression)))
-
-(define (syntax-expressions expressions)
- (if (null? expressions)
- '()
- (cons (syntax-expression (car expressions))
- (syntax-expressions (cdr expressions)))))
-
-(define ((spread-arguments kernel) expression)
- (apply kernel (cdr expression)))
-
-(define saved-keyword
- (make-interned-symbol ""))
-
-(define (syntax-error message . irritant)
- (error (string-append message
- ": "
- (symbol->string saved-keyword)
- " SYNTAX")
- (cond ((null? irritant) *the-non-printing-object*)
- ((null? (cdr irritant)) (car irritant))
- (else irritant))))
-\f
-(define (syntax-sequence subexpressions)
- (if (null? subexpressions)
- (syntax-error "No subforms in sequence")
- (make-sequence (syntax-sequentially subexpressions))))
-
-(define (syntax-sequentially expressions)
- (if (null? expressions)
- '()
- ;; force eval order.
- (let ((first (syntax-expression (car expressions))))
- (cons first
- (syntax-sequentially (cdr expressions))))))
-
-(define (syntax-bindings bindings receiver)
- (cond ((null? bindings)
- (receiver '() '()))
- ((and (pair? (car bindings))
- (symbol? (caar bindings)))
- (syntax-bindings (cdr bindings)
- (lambda (names values)
- (receiver (cons (caar bindings) names)
- (cons (expand-binding-value (cdar bindings)) values)))))
- (else
- (syntax-error "Badly-formed binding" (car bindings)))))
-\f
-;;;; Expanders
-
-(define (expand-access chain cont)
- (if (symbol? (car chain))
- (cont (if (null? (cddr chain))
- (syntax-expression (cadr chain))
- (expand-access (cdr chain) make-access))
- (car chain))
- (syntax-error "Non-symbolic variable" (car chain))))
-
-(define (expand-binding-value rest)
- (cond ((null? rest) unassigned-object)
- ((null? (cdr rest)) (syntax-expression (car rest)))
- (else (syntax-error "Too many forms in value" rest))))
-
-(define expand-conjunction
- (let ()
- (define (expander forms)
- (if (null? (cdr forms))
- (syntax-expression (car forms))
- (make-conjunction (syntax-expression (car forms))
- (expander (cdr forms)))))
- (named-lambda (expand-conjunction forms)
- (if (null? forms)
- true
- (expander forms)))))
-
-(define expand-disjunction
- (let ()
- (define (expander forms)
- (if (null? (cdr forms))
- (syntax-expression (car forms))
- (make-disjunction (syntax-expression (car forms))
- (expander (cdr forms)))))
- (named-lambda (expand-disjunction forms)
- (if (null? forms)
- false
- (expander forms)))))
-
-(define (expand-lambda pattern actions receiver)
- (define (loop pattern body)
- (if (pair? (car pattern))
- (loop (car pattern)
- (make-lambda (cdr pattern) body))
- (receiver pattern body)))
- ((if (pair? pattern) loop receiver) pattern (syntax-lambda-body actions)))
-
-(define (syntax-lambda-body body)
- (syntax-sequence
- (if (and (not (null? body))
- (not (null? (cdr body)))
- (string? (car body)))
- (cdr body) ;discard documentation string.
- body)))
-\f
-;;;; Quasiquote
-
-(define expand-quasiquote)
-(let ()
-
-(define (descend-quasiquote x level return)
- (cond ((pair? x) (descend-quasiquote-pair x level return))
- ((vector? x) (descend-quasiquote-vector x level return))
- (else (return 'QUOTE x))))
-
-(define (descend-quasiquote-pair x level return)
- (define (descend-quasiquote-pair* level)
- (descend-quasiquote (car x) level
- (lambda (car-mode car-arg)
- (descend-quasiquote (cdr x) level
- (lambda (cdr-mode cdr-arg)
- (cond ((and (eq? car-mode 'QUOTE)
- (eq? cdr-mode 'QUOTE))
- (return 'QUOTE x))
- ((eq? car-mode 'UNQUOTE-SPLICING)
- (if (and (eq? cdr-mode 'QUOTE)
- (null? cdr-arg))
- (return 'UNQUOTE car-arg)
- (return (system 'APPEND)
- (list car-arg
- (finalize-quasiquote cdr-mode cdr-arg)))))
- ((and (eq? cdr-mode 'QUOTE)
- (null? cdr-arg))
- (return 'LIST
- (list (finalize-quasiquote car-mode car-arg))))
- ((and (eq? cdr-mode 'QUOTE)
- (list? cdr-arg))
- (return 'LIST
- (cons (finalize-quasiquote car-mode car-arg)
- (map (lambda (el)
- (finalize-quasiquote 'QUOTE el))
- cdr-arg))))
- ((memq cdr-mode '(LIST CONS))
- (return cdr-mode
- (cons (finalize-quasiquote car-mode car-arg)
- cdr-arg)))
- (else
- (return
- 'CONS
- (list (finalize-quasiquote car-mode car-arg)
- (finalize-quasiquote cdr-mode cdr-arg))))))))))
- (case (car x)
- ((QUASIQUOTE) (descend-quasiquote-pair* (1+ level)))
- ((UNQUOTE UNQUOTE-SPLICING)
- (if (zero? level)
- (return (car x) (cadr x))
- (descend-quasiquote-pair* (- level 1))))
- (else (descend-quasiquote-pair* level))))
-\f
-(define (descend-quasiquote-vector x level return)
- (descend-quasiquote (vector->list x) level
- (lambda (mode arg)
- (case mode
- ((QUOTE)
- (return 'QUOTE x))
- ((LIST)
- (return (system 'VECTOR) arg))
- (else
- (return (system 'LIST->VECTOR)
- (list (finalize-quasiquote mode arg))))))))
-
-(define (finalize-quasiquote mode arg)
- (case mode
- ((QUOTE) `',arg)
- ((UNQUOTE) arg)
- ((UNQUOTE-SPLICING) (error ",@ in illegal context" arg))
- ((LIST) `(,(system 'LIST) ,@arg))
- ((CONS)
- (if (= (length arg) 2)
- `(,(system 'CONS) ,@arg)
- `(,(system 'CONS*) ,@arg)))
- (else `(,mode ,@arg))))
-
-(define (system name)
- `(ACCESS ,name #F))
-
-(set! expand-quasiquote
- (named-lambda (expand-quasiquote expression)
- (syntax-expression (descend-quasiquote expression 0 finalize-quasiquote))))
-
-)
-\f
-;;;; Basic Syntax
-
-(define syntax-SCODE-QUOTE-form
- (spread-arguments
- (lambda (expression)
- (make-quotation (syntax-expression expression)))))
-
-(define syntax-QUOTE-form
- (spread-arguments identity-procedure))
-
-(define syntax-THE-ENVIRONMENT-form
- (spread-arguments make-the-environment))
-
-(define syntax-UNASSIGNED?-form
- (spread-arguments make-unassigned?))
-
-(define syntax-UNBOUND?-form
- (spread-arguments make-unbound?))
-
-(define syntax-ACCESS-form
- (spread-arguments
- (lambda chain
- (expand-access chain make-access))))
-
-(define syntax-SET!-form
- (spread-arguments
- (lambda (name . rest)
- ((syntax-extended-assignment name)
- (expand-binding-value rest)))))
-
-(define syntax-DEFINE-form
- (spread-arguments
- (lambda (pattern . rest)
- (cond ((symbol? pattern)
- (make-definition pattern
- (expand-binding-value
- (if (and (= (length rest) 2)
- (string? (cadr rest)))
- (list (car rest))
- rest))))
- ((pair? pattern)
- (expand-lambda pattern rest
- (lambda (pattern body)
- (make-definition (car pattern)
- (make-named-lambda (car pattern) (cdr pattern)
- body)))))
- (else
- (syntax-error "Bad pattern" pattern))))))
-
-(define syntax-SEQUENCE-form
- (spread-arguments
- (lambda actions
- (syntax-sequence actions))))
-\f
-(define syntax-IN-PACKAGE-form
- (spread-arguments
- (lambda (environment . body)
- (make-in-package (syntax-expression environment)
- (syntax-sequence body)))))
-
-(define syntax-DELAY-form
- (spread-arguments
- (lambda (expression)
- (make-delay (syntax-expression expression)))))
-
-(define syntax-CONS-STREAM-form
- (spread-arguments
- (lambda (head tail)
- (make-combination* cons
- (syntax-expression head)
- (make-delay (syntax-expression tail))))))
-\f
-;;;; Conditionals
-
-(define syntax-IF-form
- (spread-arguments
- (lambda (predicate consequent . rest)
- (make-conditional (syntax-expression predicate)
- (syntax-expression consequent)
- (cond ((null? rest)
- false)
- ((null? (cdr rest))
- (syntax-expression (car rest)))
- (else
- (syntax-error "Too many forms" (cdr rest))))))))
-
-(define syntax-COND-form
- (let ()
- (define (process-cond-clauses clause rest)
- (cond ((eq? (car clause) 'ELSE)
- (if (null? rest)
- (syntax-sequence (cdr clause))
- (syntax-error "ELSE not last clause" rest)))
- ((null? rest)
- (if (cdr clause)
- (make-conjunction (syntax-expression (car clause))
- (syntax-sequence (cdr clause)))
- (syntax-expression (car clause))))
- ((null? (cdr clause))
- (make-disjunction (syntax-expression (car clause))
- (process-cond-clauses (car rest)
- (cdr rest))))
- ((and (pair? (cdr clause))
- (eq? (cadr clause) '=>))
- (syntax-expression
- `((ACCESS COND-=>-HELPER SYNTAXER-PACKAGE '())
- ,(car clause)
- (DELAY ,@(cddr clause))
- (DELAY (COND ,@rest)))))
- (else
- (make-conditional (syntax-expression (car clause))
- (syntax-sequence (cdr clause))
- (process-cond-clauses (car rest)
- (cdr rest))))))
- (spread-arguments
- (lambda (clause . rest)
- (process-cond-clauses clause rest)))))
-
-(define (cond-=>-helper form1-result thunk2 thunk3)
- (if form1-result
- ((force thunk2) form1-result)
- (force thunk3)))
-
-(define (make-funcall name . args)
- (make-combination (make-variable name) args))
-\f
-(define syntax-CONJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-conjunction forms))))
-
-(define syntax-DISJUNCTION-form
- (spread-arguments
- (lambda forms
- (expand-disjunction forms))))
-\f
-;;;; Procedures
-
-(define syntax-LAMBDA-form
- (spread-arguments
- (lambda (pattern . body)
- (make-lambda pattern (syntax-lambda-body body)))))
-
-(define syntax-NAMED-LAMBDA-form
- (spread-arguments
- (lambda (pattern . body)
- (expand-lambda pattern body
- (lambda (pattern body)
- (make-named-lambda (car pattern) (cdr pattern) body))))))
-
-(define syntax-LET-form
- (spread-arguments
- (lambda (name-or-pattern pattern-or-first . rest)
- (if (symbol? name-or-pattern)
- (syntax-bindings pattern-or-first
- (lambda (names values)
- (make-letrec (list name-or-pattern)
- (list (make-named-lambda name-or-pattern names
- (syntax-sequence rest)))
- (make-combination (make-variable name-or-pattern)
- values))))
- (syntax-bindings name-or-pattern
- (lambda (names values)
- (make-closed-block
- lambda-tag:let names values
- (syntax-sequence (cons pattern-or-first rest)))))))))
-
-(define syntax-MAKE-ENVIRONMENT-form
- (spread-arguments
- (lambda body
- (make-closed-block
- lambda-tag:make-environment '() '()
- (if (null? body)
- the-environment-object
- (make-sequence* (syntax-sequence body) the-environment-object))))))
-\f
-;;;; Syntax Extensions
-
-(define syntax-LET-SYNTAX-form
- (spread-arguments
- (lambda (bindings . body)
- (syntax-bindings bindings
- (lambda (names values)
- (fluid-let ((syntax-table
- (extend-syntax-table
- (map (lambda (name value)
- (cons name (syntax-eval value)))
- names
- values)
- syntax-table)))
- (syntax-sequence body)))))))
-
-(define syntax-USING-SYNTAX-form
- (spread-arguments
- (lambda (table . body)
- (let ((table* (syntax-eval (syntax-expression table))))
- (if (not (syntax-table? table*))
- (syntax-error "Not a syntax table" table))
- (fluid-let ((syntax-table table*))
- (syntax-sequence body))))))
-
-(define syntax-DEFINE-SYNTAX-form
- (spread-arguments
- (lambda (name value)
- (cond ((symbol? name)
- (syntax-table-define syntax-table name
- (syntax-eval (syntax-expression value)))
- name)
- ((and (pair? name) (symbol? (car name)))
- (syntax-table-define syntax-table (car name)
- (let ((transformer
- (syntax-eval (syntax-NAMED-LAMBDA-form
- `(NAMED-LAMBDA ,name ,value)))))
- (lambda (expression)
- (apply transformer (cdr expression)))))
- (car name))
- (else (syntax-error "Bad syntax description" name))))))
-
-(define (syntax-MACRO-form expression)
- (make-combination* (expand-access '(MACRO-SPREADER '()) make-access)
- (syntax-LAMBDA-form expression)))
-
-(define (syntax-DEFINE-MACRO-form expression)
- (syntax-table-define syntax-table (caadr expression)
- (macro-spreader (syntax-eval (syntax-NAMED-LAMBDA-form expression))))
- (caadr expression))
-
-(set! macro-spreader
-(named-lambda ((macro-spreader transformer) expression)
- (syntax-expression (apply transformer (cdr expression)))))
-\f
-;;;; Grab Bag
-
-(define (syntax-ERROR-LIKE-form procedure-name)
- (spread-arguments
- (lambda (message . rest)
- (make-combination* (make-variable procedure-name)
- (syntax-expression message)
- (cond ((null? rest)
- ;; Slightly crockish, but prevents
- ;; hidden variable reference.
- (make-access (make-null)
- '*THE-NON-PRINTING-OBJECT*))
- ((null? (cdr rest))
- (syntax-expression (car rest)))
- (else
- (make-combination
- (make-access (make-null) 'LIST)
- (syntax-expressions rest))))
- (make-the-environment)))))
-
-(define syntax-ERROR-form
- (syntax-ERROR-LIKE-form 'ERROR-PROCEDURE))
-
-(define syntax-BKPT-form
- (syntax-ERROR-LIKE-form 'BREAKPOINT-PROCEDURE))
-
-(define syntax-QUASIQUOTE-form
- (spread-arguments expand-quasiquote))
-\f
-;;;; FLUID-LET
-
-(define syntax-FLUID-LET-form-shallow
- (let ()
-
- (define (syntax-fluid-bindings bindings receiver)
- (if (null? bindings)
- (receiver '() '() '() '())
- (syntax-fluid-bindings (cdr bindings)
- (lambda (names values transfers-in transfers-out)
- (let ((binding (car bindings)))
- (if (pair? binding)
- (let ((transfer
- (let ((assignment
- (syntax-extended-assignment (car binding))))
- (lambda (target source)
- (make-assignment
- target
- (assignment
- (make-assignment source
- unassigned-object))))))
- (value (expand-binding-value (cdr binding)))
- (inside-name
- (string->uninterned-symbol "INSIDE-PLACEHOLDER"))
- (outside-name
- (string->uninterned-symbol "OUTSIDE-PLACEHOLDER")))
- (receiver (cons* inside-name outside-name names)
- (cons* value unassigned-object values)
- (cons (transfer outside-name inside-name)
- transfers-in)
- (cons (transfer inside-name outside-name)
- transfers-out)))
- (syntax-error "Binding not a pair" binding)))))))
-
- (spread-arguments
- (lambda (bindings . body)
- (if (null? bindings)
- (syntax-sequence body)
- (syntax-fluid-bindings bindings
- (lambda (names values transfers-in transfers-out)
- (make-closed-block
- lambda-tag:shallow-fluid-let names values
- (make-combination*
- (make-variable 'DYNAMIC-WIND)
- (make-thunk (make-sequence transfers-in))
- (make-thunk (syntax-sequence body))
- (make-thunk (make-sequence transfers-out)))))))))))
-\f
-(define syntax-FLUID-LET-form-deep)
-(define syntax-FLUID-LET-form-common-lisp)
-(let ()
-
-(define (make-fluid-let primitive procedure-tag)
- ;; (FLUID-LET ((<access-or-symbol> <value>) ...) . <body>) =>
- ;; (WITH-SAVED-FLUID-BINDINGS
- ;; (LAMBDA ()
- ;; (ADD-FLUID! (THE-ENVIRONMENT) <access-or-symbol> <value>)
- ;; ...
- ;; <body>))
- (let ((with-saved-fluid-bindings
- (make-primitive-procedure 'WITH-SAVED-FLUID-BINDINGS #t)))
- (spread-arguments
- (lambda (bindings . body)
- (syntax-fluid-bindings bindings
- (lambda (names values)
- (make-combination
- (internal-make-lambda procedure-tag '() '() '()
- (make-combination
- with-saved-fluid-bindings
- (list
- (make-thunk
- (make-sequence
- (map*
- (list (syntax-sequence body))
- (lambda (name-or-access value)
- (cond ((variable? name-or-access)
- (make-combination
- primitive
- (list the-environment-object
- (make-quotation name-or-access)
- value)))
- ((access? name-or-access)
- (access-components name-or-access
- (lambda (env name)
- (make-combination primitive
- (list env name value)))))
- (else
- (syntax-error
- "Target of FLUID-LET not a symbol or ACCESS form"
- name-or-access))))
- names values))))))
- '())))))))
-\f
-(define (syntax-fluid-bindings bindings receiver)
- (if (null? bindings)
- (receiver '() '())
- (syntax-fluid-bindings
- (cdr bindings)
- (lambda (names values)
- (let ((binding (car bindings)))
- (if (pair? binding)
- (receiver (cons (let ((name (syntax-expression (car binding))))
- (if (or (variable? name)
- (access? name))
- name
- (syntax-error "Binding name illegal"
- (car binding))))
- names)
- (cons (expand-binding-value (cdr binding)) values))
- (syntax-error "Binding not a pair" binding)))))))
-
-(set! syntax-FLUID-LET-form-deep
- (make-fluid-let (make-primitive-procedure 'ADD-FLUID-BINDING! #t)
- lambda-tag:deep-fluid-let))
-
-(set! syntax-FLUID-LET-form-common-lisp
- ;; This -- groan -- is for Common Lisp support
- (make-fluid-let (make-primitive-procedure 'MAKE-FLUID-BINDING! #t)
- lambda-tag:common-lisp-fluid-let))
-
-;;; end special FLUID-LETs.
-)
-\f
-;;;; Extended Assignment Syntax
-
-(define (syntax-extended-assignment expression)
- (invert-expression (syntax-expression expression)))
-
-(define (invert-expression target)
- (cond ((variable? target)
- (invert-variable (variable-name target)))
- ((access? target)
- (access-components target invert-access))
- (else
- (syntax-error "Bad target" target))))
-
-(define ((invert-variable name) value)
- (make-assignment name value))
-
-(define ((invert-access environment name) value)
- (make-combination* lexical-assignment environment name value))
-\f
-;;;; Declarations
-
-;;; All declarations are syntactically checked; the resulting
-;;; DECLARATION objects all contain lists of standard declarations.
-;;; Each standard declaration is a proper list with symbolic keyword.
-
-(define syntax-LOCAL-DECLARE-form
- (spread-arguments
- (lambda (declarations . body)
- (make-declaration (process-declarations declarations)
- (syntax-sequence body)))))
-
-(define syntax-DECLARE-form
- (spread-arguments
- (lambda declarations
- (make-block-declaration (map process-declaration declarations)))))
-
-;;; These two procedures use `error' instead of `syntax-error' because
-;;; they are called when the syntaxer is not running.
-
-(define (process-declarations declarations)
- (if (list? declarations)
- (map process-declaration declarations)
- (error "SYNTAX: Illegal declaration list" declarations)))
-
-(define (process-declaration declaration)
- (cond ((symbol? declaration)
- (list declaration))
- ((and (list? declaration)
- (not (null? declaration))
- (symbol? (car declaration)))
- declaration)
- (else
- (error "SYNTAX: Illegal declaration" declaration))))
-\f
-;;;; SCODE Constructors
-
-(define unassigned-object
- (make-unassigned-object))
-
-(define the-environment-object
- (make-the-environment))
-
-(define (make-conjunction first second)
- (make-conditional first second false))
-
-(define (make-combination* operator . operands)
- (make-combination operator operands))
-
-(define (make-sequence* . operands)
- (make-sequence operands))
-
-(define (make-sequence operands)
- (internal-make-sequence operands))
-
-(define (make-thunk body)
- (make-lambda '() body))
-
-(define (make-lambda pattern body)
- (make-named-lambda lambda-tag:unnamed pattern body))
-
-(define (make-named-lambda name pattern body)
- (if (not (symbol? name))
- (syntax-error "Name of lambda expression must be a symbol" name))
- (parse-lambda-list pattern
- (lambda (required optional rest)
- (internal-make-lambda name required optional rest body))))
-
-(define (make-closed-block tag names values body)
- (make-combination (internal-make-lambda tag names '() '() body)
- values))
-
-(define (make-letrec names values body)
- (make-closed-block lambda-tag:let '() '()
- (make-sequence (append! (map make-definition names values)
- (list body)))))
-\f
-;;;; Lambda List Parser
-
-(define (parse-lambda-list lambda-list receiver)
- (let ((required (list '()))
- (optional (list '())))
- (define (parse-parameters cell)
- (define (loop pattern)
- (cond ((null? pattern) (finish false))
- ((symbol? pattern) (finish pattern))
- ((not (pair? pattern)) (bad-lambda-list pattern))
- ((eq? (car pattern) (access lambda-rest-tag lambda-package))
- (if (and (pair? (cdr pattern)) (null? (cddr pattern)))
- (cond ((symbol? (cadr pattern)) (finish (cadr pattern)))
- ((and (pair? (cadr pattern))
- (symbol? (caadr pattern)))
- (finish (caadr pattern)))
- (else (bad-lambda-list (cdr pattern))))
- (bad-lambda-list (cdr pattern))))
- ((eq? (car pattern) (access lambda-optional-tag lambda-package))
- (if (eq? cell required)
- ((parse-parameters optional) (cdr pattern))
- (bad-lambda-list pattern)))
- ((symbol? (car pattern))
- (set-car! cell (cons (car pattern) (car cell)))
- (loop (cdr pattern)))
- ((and (pair? (car pattern)) (symbol? (caar pattern)))
- (set-car! cell (cons (caar pattern) (car cell)))
- (loop (cdr pattern)))
- (else (bad-lambda-list pattern))))
- loop)
-
- (define (finish rest)
- (receiver (reverse! (car required))
- (reverse! (car optional))
- rest))
-
- (define (bad-lambda-list pattern)
- (syntax-error "Illegally-formed lambda-list" pattern))
-
- ((parse-parameters required) lambda-list)))
-\f
-;;;; Scan Defines
-
-(define no-scan-make-sequence
- external-make-sequence)
-
-(define (scanning-make-sequence actions)
- (scan-defines (external-make-sequence actions)
- make-open-block))
-
-(define (no-scan-make-lambda name required optional rest body)
- (external-make-lambda name required optional rest '() '() body))
-
-(define scanning-make-lambda
- make-lambda*)
-
-(define internal-make-sequence)
-(define internal-make-lambda)
-
-(set! enable-scan-defines!
-(named-lambda (enable-scan-defines!)
- (set! internal-make-sequence scanning-make-sequence)
- (set! internal-make-lambda scanning-make-lambda)))
-
-(set! with-scan-defines-enabled
-(named-lambda (with-scan-defines-enabled thunk)
- (fluid-let ((internal-make-sequence scanning-make-sequence)
- (internal-make-lambda scanning-make-lambda))
- (thunk))))
-
-(set! disable-scan-defines!
-(named-lambda (disable-scan-defines!)
- (set! internal-make-sequence no-scan-make-sequence)
- (set! internal-make-lambda no-scan-make-lambda)))
-
-(set! with-scan-defines-disabled
-(named-lambda (with-scan-defines-disabled thunk)
- (fluid-let ((internal-make-sequence no-scan-make-sequence)
- (internal-make-lambda no-scan-make-lambda))
- (thunk))))
-
-(define ((fluid-let-maker marker which-kind) #!optional name)
- (if (unassigned? name) (set! name 'FLUID-LET))
- (if (eq? name 'FLUID-LET) (set! *fluid-let-type* marker))
- (add-syntax! name which-kind))
-
-(set! shallow-fluid-let!
- (fluid-let-maker 'SHALLOW syntax-fluid-let-form-shallow))
-(set! deep-fluid-let!
- (fluid-let-maker 'DEEP syntax-fluid-let-form-deep))
-(set! common-lisp-fluid-let!
- (fluid-let-maker 'COMMON-LISP syntax-fluid-let-form-common-lisp))
-\f
-;;;; Top Level Syntaxers
-
-(define syntax-table)
-
-(define syntax-environment
- (in-package system-global-environment
- (make-environment)))
-
-;;; The top level procedures, when not given an argument, use whatever
-;;; the current syntax table is. This is reasonable only while inside
-;;; a syntaxer quantum, since at other times there is current table.
-
-(define ((make-syntax-top-level syntaxer) expression #!optional table)
- (if (unassigned? table)
- (syntaxer expression)
- (begin (check-syntax-table table 'SYNTAX)
- (fluid-let ((syntax-table table))
- (syntaxer expression)))))
-
-(set! syntax (make-syntax-top-level syntax-expression))
-(set! syntax* (make-syntax-top-level syntax-sequence))
-
-(define (syntax-eval scode)
- (scode-eval scode syntax-environment))
-\f
-;;;; Syntax Table
-
-(define syntax-table-tag
- '(SYNTAX-TABLE))
-
-(set! syntax-table?
-(named-lambda (syntax-table? object)
- (and (pair? object)
- (eq? (car object) syntax-table-tag))))
-
-(define (check-syntax-table table name)
- (if (not (syntax-table? table))
- (error "Not a syntax table" name table)))
-
-(set! make-syntax-table
-(named-lambda (make-syntax-table #!optional parent)
- (cons syntax-table-tag
- (cons '()
- (if (unassigned? parent)
- '()
- (cdr parent))))))
-
-(set! extend-syntax-table
-(named-lambda (extend-syntax-table alist #!optional table)
- (if (unassigned? table) (set! table (current-syntax-table)))
- (check-syntax-table table 'EXTEND-SYNTAX-TABLE)
- (cons syntax-table-tag (cons alist (cdr table)))))
-
-(set! copy-syntax-table
-(named-lambda (copy-syntax-table #!optional table)
- (if (unassigned? table) (set! table (current-syntax-table)))
- (check-syntax-table table 'COPY-SYNTAX-TABLE)
- (cons syntax-table-tag
- (map (lambda (alist)
- (map (lambda (pair)
- (cons (car pair) (cdr pair)))
- alist))
- (cdr table)))))
-\f
-(set! syntax-table-ref
-(named-lambda (syntax-table-ref table name)
- (define (loop frames)
- (and (not (null? frames))
- (let ((entry (assq name (car frames))))
- (if entry
- (cdr entry)
- (loop (cdr frames))))))
- (check-syntax-table table 'SYNTAX-TABLE-REF)
- (loop (cdr table))))
-
-(set! syntax-table-define
-(named-lambda (syntax-table-define table name quantum)
- (check-syntax-table table 'SYNTAX-TABLE-DEFINE)
- (let ((entry (assq name (cadr table))))
- (if entry
- (set-cdr! entry quantum)
- (set-car! (cdr table)
- (cons (cons name quantum)
- (cadr table)))))))
-
-(set! syntax-table-shadow
-(named-lambda (syntax-table-shadow table name)
- (check-syntax-table table 'SYNTAX-TABLE-SHADOW)
- (let ((entry (assq name (cadr table))))
- (if entry
- (set-cdr! entry false)
- (set-car! (cdr table)
- (cons (cons name false)
- (cadr table)))))))
-
-(set! syntax-table-undefine
-(named-lambda (syntax-table-undefine table name)
- (check-syntax-table table 'SYNTAX-TABLE-UNDEFINE)
- (if (assq name (cadr table))
- (set-car! (cdr table)
- (del-assq! name (cadr table))))))
-\f
-;;;; Default Syntax
-
-(enable-scan-defines!)
-
-(set! system-global-syntax-table
- (cons syntax-table-tag
- `(((ACCESS . ,syntax-ACCESS-form)
- (AND . ,syntax-CONJUNCTION-form)
- (BEGIN . ,syntax-SEQUENCE-form)
- (BKPT . ,syntax-BKPT-form)
- (COND . ,syntax-COND-form)
- (CONS-STREAM . ,syntax-CONS-STREAM-form)
- (DECLARE . ,syntax-DECLARE-form)
- (DEFINE . ,syntax-DEFINE-form)
- (DEFINE-SYNTAX . ,syntax-DEFINE-SYNTAX-form)
- (DEFINE-MACRO . ,syntax-DEFINE-MACRO-form)
- (DELAY . ,syntax-DELAY-form)
- (ERROR . ,syntax-ERROR-form)
- (FLUID-LET . ,syntax-FLUID-LET-form-shallow)
- (IF . ,syntax-IF-form)
- (IN-PACKAGE . ,syntax-IN-PACKAGE-form)
- (LAMBDA . ,syntax-LAMBDA-form)
- (LET . ,syntax-LET-form)
- (LET-SYNTAX . ,syntax-LET-SYNTAX-form)
- (LOCAL-DECLARE . ,syntax-LOCAL-DECLARE-form)
- (MACRO . ,syntax-MACRO-form)
- (MAKE-ENVIRONMENT . ,syntax-MAKE-ENVIRONMENT-form)
- (NAMED-LAMBDA . ,syntax-NAMED-LAMBDA-form)
- (OR . ,syntax-DISJUNCTION-form)
- ;; The funniness here prevents QUASIQUOTE from being
- ;; seen as a nested backquote.
- (,'QUASIQUOTE . ,syntax-QUASIQUOTE-form)
- (QUOTE . ,syntax-QUOTE-form)
- (SCODE-QUOTE . ,syntax-SCODE-QUOTE-form)
- (SEQUENCE . ,syntax-SEQUENCE-form)
- (SET! . ,syntax-SET!-form)
- (THE-ENVIRONMENT . ,syntax-THE-ENVIRONMENT-form)
- (UNASSIGNED? . ,syntax-UNASSIGNED?-form)
- (UNBOUND? . ,syntax-UNBOUND?-form)
- (USING-SYNTAX . ,syntax-USING-SYNTAX-form)
- ))))
-
-;;; end SYNTAXER-PACKAGE
-)
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sysclk.scm,v 13.41 1987/01/23 00:21:27 jinx Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; System Clock
-
-(declare (usual-integrations))
-\f
-(define system-clock)
-(define runtime)
-(define measure-interval)
-(define wait-interval)
-
-(let ((primitive-clock (make-primitive-procedure 'SYSTEM-CLOCK))
- (offset-time)
- (non-runtime))
-
-(define (clock)
- (- (primitive-clock) offset-time))
-
-(define (ticks->seconds ticks)
- (/ ticks 100))
-
-(define (seconds->ticks seconds)
- (* seconds 100))
-
-(define (reset-system-clock!)
- (set! offset-time (primitive-clock))
- (set! non-runtime 0))
-
-(reset-system-clock!)
-(add-event-receiver! event:after-restore reset-system-clock!)
-
-(set! system-clock
- (named-lambda (system-clock)
- (ticks->seconds (clock))))
-
-(set! runtime
- (named-lambda (runtime)
- (ticks->seconds (- (clock) non-runtime))))
-
-(set! measure-interval
- (named-lambda (measure-interval runtime? thunk)
- (let ((start (clock)))
- (let ((receiver (thunk (ticks->seconds start))))
- (let ((end (clock)))
- (if (not runtime?)
- (set! non-runtime (+ (- end start) non-runtime)))
- (receiver (ticks->seconds end)))))))
-
-(set! wait-interval
- (named-lambda (wait-interval number-of-seconds)
- (let ((end (+ (clock) (seconds->ticks number-of-seconds))))
- (let wait-loop ()
- (if (< (clock) end)
- (wait-loop))))))
-
-;;; end LET.
-)
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/system.scm,v 13.45 1987/04/13 18:44:18 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Systems
-
-(declare (usual-integrations))
-\f
-;;; (DISK-SAVE filename #!optional identify)
-;;; (DUMP-WORLD filename #!optional identify)
-;;; Saves a world image in FILENAME. IDENTIFY has the following meaning:
-;;;
-;;; [] Not supplied => ^G on restore (normal for saving band).
-;;; [] String => New world ID message, and ^G on restore.
-;;; [] Otherwise => Returns normally (very useful for saving bugs!).
-;;;
-;;; The image saved by DISK-SAVE does not include the "microcode", the
-;;; one saved by DUMP-WORLD does, and is an executable file.
-
-(define disk-save)
-(define dump-world)
-(define event:after-restore)
-(define event:after-restart)
-(define full-quit)
-(define identify-world)
-(define identify-system)
-(define add-system!)
-(define add-secondary-gc-daemon!)
-(let ()
-
-(define world-identification "Scheme")
-(define known-systems '())
-(define secondary-gc-daemons '())
-(define date-world-saved)
-(define time-world-saved)
-
-(define (restart-world)
- (screen-clear)
- (abort->top-level
- (lambda ()
- (identify-world)
- (event:after-restart))))
-\f
-(define (setup-image save-image)
- (lambda (filename #!optional identify)
- (let ((d (date)) (t (time)))
- (gc-flip)
- ((access trigger-daemons garbage-collector-package) secondary-gc-daemons)
- (save-image filename
- (lambda (ie)
- (set-interrupt-enables! ie)
- (set! date-world-saved d)
- (set! time-world-saved t)
- *the-non-printing-object*)
- (lambda (ie)
- (set-interrupt-enables! ie)
- (set! date-world-saved d)
- (set! time-world-saved t)
- (event:after-restore)
- (cond ((unassigned? identify)
- (restart-world))
- ((string? identify)
- (set! world-identification identify)
- (restart-world))
- (else
- *the-non-printing-object*)))))))
-
-(set! disk-save
- (setup-image save-world))
-
-(set! dump-world
- (setup-image
- (let ((primitive (make-primitive-procedure 'DUMP-WORLD true)))
- (lambda (filename after-dumping after-restoring)
- (let ((ie (set-interrupt-enables! interrupt-mask-none)))
- ((if (primitive filename)
- after-restoring
- after-dumping)
- ie))))))
-\f
-(set! event:after-restore (make-event-distributor))
-(set! event:after-restart (make-event-distributor))
-
-(add-event-receiver! event:after-restart
- (lambda ()
- (if (not (unassigned? init-file-pathname))
- (let ((file
- (or (pathname->input-truename
- (merge-pathnames init-file-pathname
- (working-directory-pathname)))
- (pathname->input-truename
- (merge-pathnames init-file-pathname
- (home-directory-pathname))))))
- (if (not (null? file))
- (load file user-initial-environment))))))
-
-;; This is not the right place for this, but I don't know what is.
-
-(add-event-receiver!
- event:after-restore
- (lambda ()
- ((access reset! continuation-package))))
-\f
-(set! full-quit
-(named-lambda (full-quit)
- (quit)
- (restart-world)))
-
-(set! identify-world
-(named-lambda (identify-world)
- (newline)
- (write-string world-identification)
- (write-string " saved on ")
- (write-string (apply date->string date-world-saved))
- (write-string " at ")
- (write-string (apply time->string time-world-saved))
- (newline)
- (write-string " Release ")
- (write-string (access :release microcode-system))
- (for-each identify-system known-systems)))
-
-(set! identify-system
-(named-lambda (identify-system system)
- (newline)
- (write-string " ")
- (write-string (access :name system))
- (write-string " ")
- (write (access :version system))
- (let ((mod (access :modification system)))
- (if mod
- (begin (write-string ".")
- (write mod))))))
-
-(set! add-system!
-(named-lambda (add-system! system)
- (set! known-systems (append! known-systems (list system)))))
-
-(set! add-secondary-gc-daemon!
-(named-lambda (add-secondary-gc-daemon! daemon)
- (if (not (memq daemon secondary-gc-daemons))
- (set! secondary-gc-daemons (cons daemon secondary-gc-daemons)))))
-
-)
-\f
-;;; Load the given system, which must have the following variables
-;;; defined:
-;;;
-;;; :FILES which will be assigned the list of filenames actually
-;;; loaded.
-;;;
-;;; :FILES-LISTS which should contain a list of pairs, the car of each
-;;; pair being an environment, and the cdr a list of filenames. The
-;;; files are loaded in the order specified, into the environments
-;;; specified. COMPILED?, if false, means change all of the file
-;;; types to "BIN".
-
-(define load-system!)
-(let ()
-
-(set! load-system!
-(named-lambda (load-system! system #!optional compiled?)
- (if (unassigned? compiled?) (set! compiled? (query "Load compiled")))
- (define (loop files)
- (if (null? files)
- '()
- (split-list files 20
- (lambda (head tail)
- (fasload-files head
- (lambda (eval-list pure-list constant-list)
- (if (not (null? pure-list))
- (begin (newline) (write-string "Purify")
- (purify (list->vector pure-list) true)))
- (if (not (null? constant-list))
- (begin (newline) (write-string "Constantify")
- (purify (list->vector constant-list) false)))
- (append! eval-list (loop tail))))))))
- (let ((files (format-files-list (access :files-lists system) compiled?)))
- (set! (access :files system)
- (map (lambda (file) (pathname->string (car file))) files))
- (for-each (lambda (file scode)
- (newline) (write-string "Eval ")
- (write (pathname->string (car file)))
- (scode-eval scode (cdr file)))
- files
- (loop (map car files)))
- (newline)
- (write-string "Done"))
- (add-system! system)
- *the-non-printing-object*))
-
-(define (split-list list n receiver)
- (if (or (not (pair? list)) (zero? n))
- (receiver '() list)
- (split-list (cdr list) (-1+ n)
- (lambda (head tail)
- (receiver (cons (car list) head) tail)))))
-\f
-(define (fasload-files pathnames receiver)
- (if (null? pathnames)
- (receiver '() '() '())
- (fasload-file (car pathnames)
- (lambda (scode)
- (fasload-files (cdr pathnames)
- (lambda (eval-list pure-list constant-list)
- (receiver (cons scode eval-list)
- (cons scode pure-list)
- constant-list))))
- (lambda (scode)
- (fasload-files (cdr pathnames)
- (lambda (eval-list pure-list constant-list)
- (receiver (cons scode eval-list)
- pure-list
- (cons scode constant-list))))))))
-
-(define (fasload-file pathname if-pure if-not-pure)
- (let ((type (pathname-type pathname)))
- (cond ((string-ci=? "bin" type) (if-pure (fasload pathname)))
- ((string-ci=? "com" type) (if-not-pure (fasload pathname)))
- (else (error "Unknown file type" type)))))
-
-(define (format-files-list files-lists compiled?)
- (mapcan (lambda (files-list)
- (map (lambda (filename)
- (let ((pathname (->pathname filename)))
- (cons (if compiled?
- pathname
- (pathname-new-type pathname "bin"))
- (car files-list))))
- (cdr files-list)))
- files-lists))
-
-(define (query prompt)
- (newline)
- (write-string prompt)
- (write-string " (Y or N)? ")
- (let ((char (char-upcase (read-char))))
- (cond ((char=? #\Y char)
- (write-string "Yes")
- true)
- ((char=? #\N char)
- (write-string "No")
- false)
- (else (beep) (query prompt)))))
-
-)
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unpars.scm,v 13.42 1987/02/20 13:49:28 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Unparser
-
-(declare (usual-integrations))
-\f
-;;; Control Variables
-(define *unparser-radix* #d10)
-(define *unparser-list-breadth-limit* false)
-(define *unparser-list-depth-limit* false)
-
-(define (unparse-with-brackets thunk)
- (write-string "#[")
- (thunk)
- (write-char #\]))
-
-(define unparser-package
- (make-environment
-
-(define *unparse-char)
-(define *unparse-string)
-(define *unparser-list-depth*)
-(define *slashify*)
-
-(define (unparse-object object port #!optional slashify)
- (if (unassigned? slashify) (set! slashify true))
- (fluid-let ((*unparse-char (access :write-char port))
- (*unparse-string (access :write-string port))
- (*unparser-list-depth* 0)
- (*slashify* slashify))
- (*unparse-object-or-future object)))
-
-(define (*unparse-object-or-future object)
- (if (future? object)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "FUTURE ")
- (unparse-datum object)))
- (*unparse-object object)))
-
-(define (*unparse-object object)
- ((vector-ref dispatch-vector (primitive-type object)) object))
-
-(define (*unparse-substring string start end)
- (*unparse-string (substring string start end)))
-
-(define (unparse-default object)
- (unparse-with-brackets
- (lambda ()
- (*unparse-object (or (object-type object)
- `(UNDEFINED-TYPE-CODE ,(primitive-type object))))
- (*unparse-char #\Space)
- (unparse-datum object))))
-
-(define dispatch-vector
- (vector-cons number-of-microcode-types unparse-default))
-
-(define (define-type type dispatcher)
- (vector-set! dispatch-vector (microcode-type type) dispatcher))
-\f
-(define-type 'NULL
- (lambda (x)
- (if (eq? x '())
- (*unparse-string "()")
- (unparse-default x))))
-
-(define-type 'TRUE
- (lambda (x)
- (if (eq? x true)
- (*unparse-string "#T")
- (unparse-default x))))
-
-(define-type 'RETURN-ADDRESS
- (lambda (return-address)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "RETURN-ADDRESS ")
- (*unparse-object (return-address-name return-address))))))
-
-(define (unparse-unassigned x)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNASSIGNED"))))
-
-(define (unparse-unbound x)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNBOUND"))))
-
-(define (unparse-symbol symbol)
- (*unparse-string (symbol->string symbol)))
-
-(define-type 'INTERNED-SYMBOL
- unparse-symbol)
-
-(define-type 'UNINTERNED-SYMBOL
- (lambda (symbol)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "UNINTERNED ")
- (unparse-symbol symbol)
- (*unparse-char #\Space)
- (*unparse-object (object-hash symbol))))))
-
-(define-type 'CHARACTER
- (lambda (character)
- (if *slashify*
- (begin (*unparse-string "#\\")
- (*unparse-string (char->name character true)))
- (*unparse-char character))))
-\f
-(define-type 'STRING
- (let ((delimiters (char-set #\" #\\ #\Tab char:newline #\Page)))
- (lambda (string)
- (if *slashify*
- (begin (*unparse-char #\")
- (let ((end (string-length string)))
- (define (loop start)
- (let ((index (substring-find-next-char-in-set
- string start end delimiters)))
- (if index
- (begin (*unparse-substring string start index)
- (*unparse-char #\\)
- (*unparse-char
- (let ((char (string-ref string index)))
- (cond ((char=? char #\Tab) #\t)
- ((char=? char char:newline) #\n)
- ((char=? char #\Page) #\f)
- (else char))))
- (loop (1+ index)))
- (*unparse-substring string start end))))
- (if (substring-find-next-char-in-set string 0 end
- delimiters)
- (loop 0)
- (*unparse-string string)))
- (*unparse-char #\"))
- (*unparse-string string)))))
-
-(define-type 'VECTOR
- (lambda (vector)
- (define (normal)
- (*unparse-char #\#)
- (unparse-list (vector->list vector)))
- (cond ((zero? (vector-length vector)) (*unparse-string "#()"))
- ((future? vector) (normal))
- (else
- (let ((entry
- (assq (vector-ref vector 0) *unparser-special-objects*)))
- (if entry
- ((cdr entry) vector)
- (normal)))))))
-
-(define *unparser-special-objects* '())
-
-(define (add-unparser-special-object! key unparser)
- (set! *unparser-special-objects*
- (cons (cons key unparser)
- *unparser-special-objects*))
- *the-non-printing-object*)
-\f
-(define-type 'LIST
- (lambda (object)
- ((cond ((future? (car object)) unparse-list)
- ((unassigned-object? object) unparse-unassigned)
- ((unbound-object? object) unparse-unbound)
- (else
- (let ((entry (assq (car object) *unparser-special-pairs*)))
- (if entry
- (cdr entry)
- unparse-list))))
- object)))
-
-(define *unparser-special-pairs* '())
-
-(define (add-unparser-special-pair! key unparser)
- (set! *unparser-special-pairs*
- (cons (cons key unparser)
- *unparser-special-pairs*))
- *the-non-printing-object*)
-
-(add-unparser-special-pair! 'QUOTE
- (lambda (pair)
- (if (and (pair? (cdr pair))
- (null? (cddr pair)))
- (begin (*unparse-char #\')
- (*unparse-object-or-future (cadr pair)))
- (unparse-list pair))))
-
-(define (unparse-list list)
- (if *unparser-list-depth-limit*
- (fluid-let ((*unparser-list-depth* (1+ *unparser-list-depth*)))
- (if (> *unparser-list-depth* *unparser-list-depth-limit*)
- (*unparse-string "...")
- (begin (*unparse-char #\()
- (*unparse-object-or-future (car list))
- (unparse-tail (cdr list) 2)
- (*unparse-char #\)))))
- (begin (*unparse-char #\()
- (*unparse-object-or-future (car list))
- (unparse-tail (cdr list) 2)
- (*unparse-char #\)))))
-
-(define (unparse-tail l n)
- (cond ((pair? l)
- (*unparse-char #\Space)
- (*unparse-object-or-future (car l))
- (if (and *unparser-list-breadth-limit*
- (>= n *unparser-list-breadth-limit*)
- (not (null? (cdr l))))
- (*unparse-string " ...")
- (unparse-tail (cdr l) (1+ n))))
- ((not (null? l))
- (*unparse-string " . ")
- (*unparse-object-or-future l))))
-\f
-;;;; Procedures and Environments
-
-(define (unparse-compound-procedure procedure)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "COMPOUND-PROCEDURE ")
- (lambda-components* (procedure-lambda procedure)
- (lambda (name required optional rest body)
- (if (eq? name lambda-tag:unnamed)
- (unparse-datum procedure)
- (*unparse-object name)))))))
-
-(define-type 'PROCEDURE unparse-compound-procedure)
-(define-type 'EXTENDED-PROCEDURE unparse-compound-procedure)
-
-(define (unparse-primitive-procedure proc)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "PRIMITIVE-PROCEDURE ")
- (*unparse-object (primitive-procedure-name proc)))))
-
-(define-type 'PRIMITIVE unparse-primitive-procedure)
-(define-type 'PRIMITIVE-EXTERNAL unparse-primitive-procedure)
-
-(define-type 'ENVIRONMENT
- (lambda (environment)
- (if (lexical-unreferenceable? environment ':PRINT-SELF)
- (unparse-default environment)
- ((access :print-self environment)))))
-
-(define-type 'VARIABLE
- (lambda (variable)
- (unparse-with-brackets
- (lambda ()
- (*unparse-string "VARIABLE ")
- (*unparse-object (variable-name variable))))))
-
-(define (unparse-datum object)
- (*unparse-string (number->string (primitive-datum object) 16)))
-
-(define (unparse-number object)
- (*unparse-string (number->string object *unparser-radix*)))
-
-(define-type 'FIXNUM unparse-number)
-(define-type 'BIGNUM unparse-number)
-(define-type 'FLONUM unparse-number)
-(define-type 'COMPLEX unparse-number)
-
-;;; end UNPARSER-PACKAGE.
-))
-
-))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 13.42 1987/03/17 18:54:23 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of
-;;; this software shall duly acknowledge such use, in accordance
-;;; with the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; UNSYNTAX: SCODE -> S-Expressions
-
-(declare (usual-integrations))
-\f
-(define unsyntax)
-(define unsyntax-lambda-list)
-(define make-unsyntax-table)
-(define unsyntax-table?)
-(define current-unsyntax-table)
-(define set-current-unsyntax-table!)
-(define with-unsyntax-table)
-
-(define unsyntaxer-package
- (make-environment
-
-(set! unsyntax
-(named-lambda (unsyntax scode #!optional unsyntax-table)
- (let ((object (if (compound-procedure? scode)
- (procedure-lambda scode)
- scode)))
- (if (unassigned? unsyntax-table)
- (unsyntax-object object)
- (with-unsyntax-table unsyntax-table
- (lambda ()
- (unsyntax-object object)))))))
-
-(define (unsyntax-object object)
- ((unsyntax-dispatcher object) object))
-
-(define (unsyntax-objects objects)
- (if (null? objects)
- '()
- (cons (unsyntax-object (car objects))
- (unsyntax-objects (cdr objects)))))
-\f
-;;;; Unsyntax Quanta
-
-(define (unsyntax-QUOTATION quotation)
- `(SCODE-QUOTE ,(unsyntax-object (quotation-expression quotation))))
-
-(define (unsyntax-constant object)
- `(QUOTE ,object))
-
-(define (unsyntax-VARIABLE-object object)
- (variable-name object))
-
-(define (unsyntax-ACCESS-object object)
- `(ACCESS ,@(unexpand-access object)))
-
-(define (unexpand-access object)
- (if (access? object)
- (access-components object
- (lambda (environment name)
- `(,name ,@(unexpand-access environment))))
- `(,(unsyntax-object object))))
-
-(define (unsyntax-UNBOUND?-object unbound?)
- `(UNBOUND? ,(unbound?-name unbound?)))
-
-(define (unsyntax-UNASSIGNED?-object unassigned?)
- `(UNASSIGNED? ,(unassigned?-name unassigned?)))
-
-(define (unsyntax-DEFINITION-object definition)
- (definition-components definition unexpand-definition))
-
-(define (unsyntax-ASSIGNMENT-object assignment)
- (assignment-components assignment
- (lambda (name value)
- `(SET! ,name ,(unsyntax-object value)))))
-
-(define ((definition-unexpander key lambda-key) name value)
- (if (lambda? value)
- (lambda-components** value
- (lambda (lambda-name required optional rest body)
- (if (eq? lambda-name name)
- `(,lambda-key (,name . ,(lambda-list required optional rest))
- ,@(unsyntax-sequence body))
- `(,key ,name ,@(unexpand-binding-value value)))))
- `(,key ,name ,@(unexpand-binding-value value))))
-
-(define (unexpand-binding-value value)
- (if (unassigned-object? value)
- '()
- `(,(unsyntax-object value))))
-
-(define unexpand-definition
- (definition-unexpander 'DEFINE 'DEFINE))
-\f
-(define (unsyntax-COMMENT-object comment)
- (comment-components comment
- (lambda (text expression)
- `(COMMENT ,text ,(unsyntax-object expression)))))
-(define (unsyntax-DECLARATION-object declaration)
- (declaration-components declaration
- (lambda (text expression)
- `(LOCAL-DECLARE ,text ,(unsyntax-object expression)))))
-
-(define (unsyntax-SEQUENCE-object sequence)
- `(BEGIN ,@(unsyntax-sequence sequence)))
-
-(define (unsyntax-sequence sequence)
- (unsyntax-objects (sequence-actions sequence)))
-
-(define (unsyntax-OPEN-BLOCK-object open-block)
- (open-block-components open-block
- (lambda (auxiliary declarations expression)
- `(OPEN-BLOCK ,auxiliary
- ,declarations
- ,@(unsyntax-sequence expression)))))
-
-(define (unsyntax-DELAY-object object)
- `(DELAY ,(unsyntax-object (delay-expression object))))
-
-(define (unsyntax-IN-PACKAGE-object in-package)
- (in-package-components in-package
- (lambda (environment expression)
- `(IN-PACKAGE ,(unsyntax-object environment)
- ,@(unsyntax-sequence expression)))))
-
-(define (unsyntax-THE-ENVIRONMENT-object object)
- `(THE-ENVIRONMENT))
-\f
-(define (unsyntax-CONDITIONAL-object conditional)
- (conditional-components conditional unsyntax-conditional))
-
-(define (unsyntax-conditional predicate consequent alternative)
- (cond ((false? alternative)
- (if (conditional? consequent)
- `(AND ,@(unexpand-conjunction predicate consequent))
- `(IF ,(unsyntax-object predicate)
- ,(unsyntax-object consequent))))
- ((conditional? alternative)
- `(COND ,@(unsyntax-cond-conditional predicate
- consequent
- alternative)))
- (else
- `(IF ,(unsyntax-object predicate)
- ,(unsyntax-object consequent)
- ,(unsyntax-object alternative)))))
-
-(define (unsyntax-cond-conditional predicate consequent alternative)
- `((,(unsyntax-object predicate) ,@(unsyntax-sequence consequent))
- ,@(unsyntax-cond-alternative alternative)))
-
-(define (unsyntax-cond-disjunction predicate alternative)
- `((,(unsyntax-object predicate))
- ,@(unsyntax-cond-alternative alternative)))
-
-(define (unsyntax-cond-alternative alternative)
- (cond ((false? alternative) '())
- ((disjunction? alternative)
- (disjunction-components alternative unsyntax-cond-disjunction))
- ((conditional? alternative)
- (conditional-components alternative unsyntax-cond-conditional))
- (else `((ELSE ,@(unsyntax-sequence alternative))))))
-
-(define (unexpand-conjunction predicate consequent)
- (if (conditional? consequent)
- `(,(unsyntax-object predicate)
- ,@(conditional-components consequent
- (lambda (predicate consequent alternative)
- (if (false? alternative)
- (unexpand-conjunction predicate consequent)
- `(,(unsyntax-conditional predicate
- consequent
- alternative))))))
- `(,(unsyntax-object predicate) ,(unsyntax-object consequent))))
-
-(define (unsyntax-DISJUNCTION-object object)
- `(OR ,@(disjunction-components object unexpand-disjunction)))
-
-(define (unexpand-disjunction predicate alternative)
- `(,(unsyntax-object predicate)
- ,@(if (disjunction? alternative)
- (disjunction-components alternative unexpand-disjunction)
- `(,(unsyntax-object alternative)))))
-\f
-;;;; Lambdas
-
-(define (unsyntax-LAMBDA-object lambda)
- (lambda-components** lambda
- (lambda (name required optional rest body)
- (let ((bvl (lambda-list required optional rest))
- (body (unsyntax-sequence body)))
- (if (eq? name lambda-tag:unnamed)
- `(LAMBDA ,bvl ,@body)
- `(NAMED-LAMBDA (,name . ,bvl) ,@body))))))
-
-(set! unsyntax-lambda-list
-(named-lambda (unsyntax-lambda-list lambda)
- (if (not (lambda? lambda))
- (error "Must be a lambda expression" lambda))
- (lambda-components** lambda
- (lambda (name required optional rest body)
- (lambda-list required optional rest)))))
-
-(define (lambda-list required optional rest)
- (cond ((null? rest)
- (if (null? optional)
- required
- `(,@required ,(access lambda-optional-tag lambda-package)
- ,@optional)))
- ((null? optional)
- `(,@required . ,rest))
- (else
- `(,@required ,(access lambda-optional-tag lambda-package)
- ,@optional . ,rest))))
-
-(define (lambda-components** lambda receiver)
- (lambda-components lambda
- (lambda (name required optional rest auxiliary declarations body)
- (receiver name required optional rest
- (unscan-defines auxiliary declarations body)))))
-\f
-;;;; Combinations
-
-(define (unsyntax-COMBINATION-object combination)
- (combination-components combination
- (lambda (operator operands)
- (cond ((and (or (eq? operator cons)
- (and (variable? operator)
- (eq? (variable-name operator) 'CONS)))
- (= (length operands) 2)
- (delay? (cadr operands)))
- `(CONS-STREAM ,(unsyntax-object (car operands))
- ,(unsyntax-object
- (delay-expression (cadr operands)))))
- ((eq? operator error-procedure)
- (unsyntax-error-like-form operands 'ERROR))
- ((variable? operator)
- (let ((name (variable-name operator)))
- (cond ((eq? name 'ERROR-PROCEDURE)
- (unsyntax-error-like-form operands 'ERROR))
- ((eq? name 'BREAKPOINT-PROCEDURE)
- (unsyntax-error-like-form operands 'BKPT))
- (else
- (cons (unsyntax-object operator)
- (unsyntax-objects operands))))))
- ((lambda? operator)
- (lambda-components** operator
- (lambda (name required optional rest body)
- (if (and (null? optional)
- (null? rest))
- (cond ((or (eq? name lambda-tag:unnamed)
- (eq? name lambda-tag:let))
- `(LET ,(unsyntax-let-bindings required operands)
- ,@(unsyntax-sequence body)))
- ((eq? name lambda-tag:deep-fluid-let)
- (unsyntax-deep-fluid-let required operands body))
- ((eq? name lambda-tag:shallow-fluid-let)
- (unsyntax-shallow-fluid-let required operands
- body))
- ((eq? name lambda-tag:common-lisp-fluid-let)
- (unsyntax-common-lisp-fluid-let required operands
- body))
- ((eq? name lambda-tag:make-environment)
- (unsyntax-make-environment required operands body))
- (else
- `(LET ,name
- ,(unsyntax-let-bindings required operands)
- ,@(unsyntax-sequence body))))
- (cons (unsyntax-object operator)
- (unsyntax-objects operands))))))
- (else
- (cons (unsyntax-object operator)
- (unsyntax-objects operands)))))))
-\f
-(define (unsyntax-error-like-form operands name)
- (cons* name
- (unsyntax-object (first operands))
- (let ((operand (second operands)))
- (cond ((and (access? operand)
- (null? (access-environment operand))
- (eq? (access-name operand) '*THE-NON-PRINTING-OBJECT*))
- '())
- ((combination? operand)
- (combination-components operand
- (lambda (operator operands)
- (if (and (access? operator)
- (access-components operator
- (lambda (environment name)
- (and (eq? name 'LIST)
- (null? environment)))))
- (unsyntax-objects operands)
- `(,(unsyntax-object operand))))))
- (else `(,(unsyntax-object operand)))))))
-
-(define (unsyntax-shallow-FLUID-LET names values body)
- (combination-components body
- (lambda (operator operands)
- `(FLUID-LET ,(unsyntax-let-bindings
- (map extract-transfer-var
- (lambda-components** (car operands)
- (lambda (name req opt rest body)
- (sequence-actions body))))
- (every-other values))
- ,@(lambda-components** (cadr operands)
- (lambda (name required optional rest body)
- (unsyntax-sequence body)))))))
-
-(define (every-other list)
- (if (null? list)
- '()
- (cons (car list) (every-other (cddr list)))))
-
-(define (extract-transfer-var assignment)
- (assignment-components assignment
- (lambda (name value)
- (cond ((assignment? value)
- (assignment-components value (lambda (name value) name)))
- ((combination? value)
- (combination-components value
- (lambda (operator operands)
- (cond ((eq? operator lexical-assignment)
- `(ACCESS ,(cadr operands)
- ,@(unexpand-access (car operands))))
- (else
- (error "Unknown SCODE form" 'FLUID-LET
- assignment))))))
- (else
- (error "Unknown SCODE form" 'FLUID-LET assignment))))))
-\f
-(define ((unsyntax-deep-or-common-FLUID-LET name prim)
- ignored-required ignored-operands body)
- (define (sequence->list seq)
- (if (sequence? seq)
- (sequence-actions seq)
- (list seq)))
- (define (unsyntax-fluid-bindings l)
- (define (unsyntax-fluid-assignment combi)
- (let ((operands (combination-operands combi)))
- (let ((env (first operands))
- (name (second operands))
- (val (third operands)))
- (cond ((symbol? name)
- `((ACCESS ,name ,(unsyntax-object env))
- ,(unsyntax-object val)))
- ((quotation? name)
- (let ((var (quotation-expression name)))
- (if (variable? var)
- `(,(variable-name var) ,(unsyntax-object val))
- (error "FLUID-LET unsyntax: unexpected name" name))))
- (else
- (error "FLUID-LET unsyntax: unexpected name" name))))))
- (let ((first (car l)))
- (if (and (combination? first)
- (eq? (combination-operator first) prim))
- (let ((remainder (unsyntax-fluid-bindings (cdr l))))
- (cons
- (cons (unsyntax-fluid-assignment first) (car remainder))
- (cdr remainder)))
- (cons '() (unsyntax-objects l)))))
-
- (let* ((thunk (car (combination-operands body)))
- (real-body (lambda-body thunk))
- (seq-list (sequence->list real-body))
- (fluid-binding-list (unsyntax-fluid-bindings seq-list)))
- `(,name ,(car fluid-binding-list) ,@(cdr fluid-binding-list))))
-
-(define unsyntax-deep-FLUID-LET
- (unsyntax-deep-or-common-FLUID-LET
- 'FLUID-LET (make-primitive-procedure 'add-fluid-binding! true)))
-
-(define unsyntax-common-lisp-FLUID-LET
- (unsyntax-deep-or-common-FLUID-LET
- 'FLUID-BIND (make-primitive-procedure 'make-fluid-binding! true)))
-
-(define (unsyntax-MAKE-ENVIRONMENT names values body)
- `(MAKE-ENVIRONMENT ,@(except-last-pair (unsyntax-sequence body))))
-
-(define (unsyntax-let-bindings names values)
- (map unsyntax-let-binding names values))
-
-(define (unsyntax-let-binding name value)
- `(,name ,@(unexpand-binding-value value)))
-\f
-;;;; Unsyntax Tables
-
-(define unsyntax-table-tag
- '(UNSYNTAX-TABLE))
-
-(set! make-unsyntax-table
-(named-lambda (make-unsyntax-table alist)
- (cons unsyntax-table-tag
- (make-type-dispatcher alist identity-procedure))))
-
-(set! unsyntax-table?
-(named-lambda (unsyntax-table? object)
- (and (pair? object)
- (eq? (car object) unsyntax-table-tag))))
-
-(set! current-unsyntax-table
-(named-lambda (current-unsyntax-table)
- *unsyntax-table))
-
-(set! set-current-unsyntax-table!
-(named-lambda (set-current-unsyntax-table! table)
- (if (not (unsyntax-table? table))
- (error "Not an unsyntax table" 'SET-CURRENT-UNSYNTAX-TABLE! table))
- (set-table! table)))
-
-(set! with-unsyntax-table
-(named-lambda (with-unsyntax-table table thunk)
- (define old-table)
- (if (not (unsyntax-table? table))
- (error "Not an unsyntax table" 'WITH-UNSYNTAX-TABLE table))
- (dynamic-wind (lambda ()
- (set! old-table (set-table! table)))
- thunk
- (lambda ()
- (set! table (set-table! old-table))))))
-
-(define unsyntax-dispatcher)
-(define *unsyntax-table)
-
-(define (set-table! table)
- (set! unsyntax-dispatcher (cdr table))
- (set! *unsyntax-table table))
-\f
-;;;; Default Unsyntax Table
-
-(set-table!
- (make-unsyntax-table
- `((,(microcode-type-object 'LIST) ,unsyntax-constant)
- (,symbol-type ,unsyntax-constant)
- (,variable-type ,unsyntax-VARIABLE-object)
- (,unbound?-type ,unsyntax-UNBOUND?-object)
- (,unassigned?-type ,unsyntax-UNASSIGNED?-object)
- (,combination-type ,unsyntax-COMBINATION-object)
- (,quotation-type ,unsyntax-QUOTATION)
- (,access-type ,unsyntax-ACCESS-object)
- (,definition-type ,unsyntax-DEFINITION-object)
- (,assignment-type ,unsyntax-ASSIGNMENT-object)
- (,conditional-type ,unsyntax-CONDITIONAL-object)
- (,disjunction-type ,unsyntax-DISJUNCTION-object)
- (,comment-type ,unsyntax-COMMENT-object)
- (,declaration-type ,unsyntax-DECLARATION-object)
- (,sequence-type ,unsyntax-SEQUENCE-object)
- (,open-block-type ,unsyntax-OPEN-BLOCK-object)
- (,delay-type ,unsyntax-DELAY-object)
- (,in-package-type ,unsyntax-IN-PACKAGE-object)
- (,the-environment-type ,unsyntax-THE-ENVIRONMENT-object)
- (,lambda-type ,unsyntax-LAMBDA-object))))
-
-;;; end UNSYNTAXER-PACKAGE
-))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxpth.scm,v 1.2 1987/03/17 18:54:38 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Unix pathname parsing and unparsing.
-
-(declare (usual-integrations))
-
-;;; A note about parsing of filename strings: the standard syntax for
-;;; a filename string is "<name>.<version>.<type>". Since the Unix
-;;; file system treats "." just like any other character, it is
-;;; possible to give files strange names like "foo.bar.baz.mum". In
-;;; this case, the resulting name would be "foo.bar.baz", and the
-;;; resulting type would be "mum". In general, degenerate filenames
-;;; (including names with non-numeric versions) are parsed such that
-;;; the characters following the final "." become the type, while the
-;;; characters preceding the final "." become the name.
-\f
-;;;; Parse
-
-(define (symbol->pathname symbol)
- (string->pathname (string-downcase (symbol->string symbol))))
-
-(define string->pathname)
-(define home-directory-pathname)
-(let ()
-
-(set! string->pathname
- (named-lambda (string->pathname string)
- (parse-pathname string make-pathname)))
-
-(define (parse-pathname string receiver)
- (let ((components (divide-into-components (string-trim string))))
- (if (null? components)
- (receiver #F #F #F #F #F)
- (let ((components
- (append (expand-directory-prefixes (car components))
- (cdr components))))
- (parse-name (car (last-pair components))
- (lambda (name type version)
- (receiver #F
- (map (lambda (component)
- (if (string=? "*" component)
- 'WILD
- component))
- (except-last-pair components))
- name type version)))))))
-
-(define (divide-into-components string)
- (let ((end (string-length string)))
- (define (loop start)
- (let ((index (substring-find-next-char string start end #\/)))
- (if index
- (cons (substring string start index)
- (loop (1+ index)))
- (list (substring string start end)))))
- (loop 0)))
-\f
-(define (expand-directory-prefixes string)
- (if (string-null? string)
- (list string)
- (case (string-ref string 0)
- ((#\$)
- (divide-into-components
- (get-environment-variable
- (substring string 1 (string-length string)))))
- ((#\~)
- (let ((user-name (substring string 1 (string-length string))))
- (divide-into-components
- (if (string-null? user-name)
- (get-environment-variable "HOME")
- (get-user-home-directory user-name)))))
- (else (list string)))))
-
-(set! home-directory-pathname
- (lambda ()
- (make-pathname #F
- (divide-into-components (get-environment-variable "HOME"))
- #F
- #F
- #F)))
-
-(define get-environment-variable
- (let ((primitive (make-primitive-procedure 'GET-ENVIRONMENT-VARIABLE)))
- (lambda (name)
- (or (primitive name)
- (error "GET-ENVIRONMENT-VARIABLE: Unbound name" name)))))
-
-(define get-user-home-directory
- (let ((primitive (make-primitive-procedure 'GET-USER-HOME-DIRECTORY)))
- (lambda (user-name)
- (or (primitive user-name)
- (error "User has no home directory" user-name)))))
-
-(define (digits->number digits weight accumulator)
- (if (null? digits)
- accumulator
- (let ((value (char->digit (car digits) 10)))
- (and value
- (digits->number (cdr digits)
- (* weight 10)
- (+ (* weight value) accumulator))))))
-\f
-(define (parse-name string receiver)
- (let ((start 0)
- (end (string-length string)))
- (define (find-next-dot start)
- (substring-find-next-char string start end #\.))
-
- (define (find-previous-dot start)
- (substring-find-previous-char string start end #\.))
-
- (define (parse-version start)
- (cond ((= start end) 'UNSPECIFIC)
- ((substring=? string start end "*" 0 1) 'WILD)
- ((substring-find-next-char string start end #\*)
- (substring string start end))
- (else
- (let ((n (digits->number (reverse! (substring->list string start
- end))
- 1 0)))
- (if (and n (>= n 0))
- (if (= n 0) 'NEWEST n)
- (substring string start end))))))
-
- (if (= start end)
- (receiver #F #F #F)
- (let ((index (find-next-dot start)))
- (if index
- (let ((start* (1+ index))
- (name (wildify string start index)))
- (if (= start* end)
- (receiver name 'UNSPECIFIC 'UNSPECIFIC)
- (or (let ((index (find-next-dot start*)))
- (and index
- (let ((version (parse-version (1+ index))))
- (and (not (string? version))
- (receiver name
- (wildify string start* index)
- version)))))
- (let ((index (find-previous-dot start)))
- (receiver (wildify string start index)
- (wildify string (1+ index) end)
- #F)))))
- (receiver (wildify string start end) #F #F))))))
-
-(define (wildify string start end)
- (if (substring=? string start end "*" 0 1)
- 'WILD
- (substring string start end)))
-
-;;; end LET.
-)
-\f
-;;;; Unparse
-
-(define pathname-unparse)
-(define pathname-unparse-name)
-(let ()
-
-(set! pathname-unparse
- (named-lambda (pathname-unparse device directory name type version)
- (unparse-device
- device
- (unparse-directory directory
- (pathname-unparse-name name type version)))))
-
-(define (unparse-device device rest)
- (let ((device-string (unparse-component device)))
- (if device-string
- (string-append device-string ":" rest)
- rest)))
-
-(define (unparse-directory directory rest)
- (cond ((null? directory) rest)
- ((pair? directory)
- (let loop ((directory directory))
- (let ((directory-string (unparse-component (car directory)))
- (rest (if (null? (cdr directory))
- rest
- (loop (cdr directory)))))
- (if directory-string
- (string-append directory-string "/" rest)
- rest))))
- (else
- (error "Unrecognizable directory" directory))))
-\f
-(set! pathname-unparse-name
- (named-lambda (pathname-unparse-name name type version)
- (let ((name-string (unparse-component name))
- (type-string (unparse-component type))
- (version-string (unparse-version version)))
- (cond ((not name-string) "")
- ((not type-string) name-string)
- ((eq? type-string 'UNSPECIFIC) (string-append name-string "."))
- ((not version-string) (string-append name-string "." type-string))
- ((eq? version-string 'UNSPECIFIC)
- (string-append name-string "." type-string "."))
- (else
- (string-append name-string "." type-string "."
- version-string))))))
-
-(define (unparse-version version)
- (if (eq? version 'NEWEST)
- "0"
- (unparse-component version)))
-
-(define (unparse-component component)
- (cond ((not component) #F)
- ((eq? component 'UNSPECIFIC) component)
- ((eq? component 'WILD) "*")
- ((string? component) component)
- ((and (integer? component) (> component 0))
- (list->string (number->digits component '())))
- (else (error "Unknown component" component))))
-
-(define (number->digits number accumulator)
- (if (zero? number)
- accumulator
- (let ((qr (integer-divide number 10)))
- (number->digits (integer-divide-quotient qr)
- (cons (digit->char (integer-divide-remainder qr))
- accumulator)))))
-
-;;; end LET.
-)
-\f
-;;;; Utility for merge pathnames
-
-(define (simplify-directory directory)
- (cond ((null? directory) directory)
- ((string=? (car directory) ".")
- (simplify-directory (cdr directory)))
- ((null? (cdr directory)) directory)
- ((string=? (cadr directory) "..")
- (simplify-directory (cddr directory)))
- (else
- (cons (car directory)
- (simplify-directory (cdr directory))))))
-\f
-;;;; Working Directory
-
-(define working-directory-pathname)
-(define set-working-directory-pathname!)
-
-(define working-directory-package
- (make-environment
-
-(define primitive
- (make-primitive-procedure 'WORKING-DIRECTORY-PATHNAME))
-
-(define pathname)
-
-(define (reset!)
- (set! pathname
- (string->pathname
- (let ((string (primitive)))
- (let ((length (string-length string)))
- (if (or (zero? length)
- (not (char=? #\/ (string-ref string (-1+ length)))))
- (string-append string "/")
- string))))))
-
-(set! working-directory-pathname
- (named-lambda (working-directory-pathname)
- pathname))
-
-(set! set-working-directory-pathname!
- (named-lambda (set-working-directory-pathname! name)
- (set! pathname
- (pathname-as-directory
- (pathname->absolute-pathname (->pathname name))))
- pathname))
-
-;;; end WORKING-DIRECTORY-PACKAGE
-))
-
-(define init-file-pathname
- (make-pathname #F #F ".scheme" "init" #F))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/utabs.scm,v 13.45 1987/04/15 05:07:31 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Microcode Table Interface
-
-(declare (usual-integrations))
-\f
-(define fixed-objects-vector-slot)
-
-(define number-of-microcode-types)
-(define microcode-type-name)
-(define microcode-type)
-(define microcode-type-predicate)
-(define object-type)
-
-(define number-of-microcode-returns)
-(define microcode-return)
-(define make-return-address)
-(define return-address?)
-(define return-address-code)
-(define return-address-name)
-
-(define number-of-microcode-errors)
-(define microcode-error)
-
-(define number-of-microcode-terminations)
-(define microcode-termination)
-(define microcode-termination-name)
-
-(define make-primitive-procedure)
-(define primitive-procedure?)
-(define primitive-procedure-name)
-(define implemented-primitive-procedure?)
-
-(define microcode-identification-item)
-
-(define future?)
-
-(define microcode-system
- (make-environment
-
-(define :name "Microcode")
-(define :version)
-(define :modification)
-(define :identification)
-(define :release)
-
-(let-syntax ((define-primitive
- (macro (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))))
- (define-primitive binary-fasload)
- (define-primitive microcode-identify)
- (define-primitive microcode-tables-filename)
- (define-primitive map-machine-address-to-code)
- (define-primitive map-code-to-machine-address)
- (define-primitive get-external-counts)
- (define-primitive get-external-number)
- (define-primitive get-external-name))
-\f
-;;;; Fixed Objects Vector
-
-(set! fixed-objects-vector-slot
-(named-lambda (fixed-objects-vector-slot name)
- (or (microcode-table-search 15 name)
- (error "FIXED-OBJECTS-VECTOR-SLOT: Unknown name" name))))
-
-(define fixed-objects)
-
-(define (microcode-table-search slot name)
- (let ((vector (vector-ref fixed-objects slot)))
- (let ((end (vector-length vector)))
- (define (loop i)
- (and (not (= i end))
- (let ((entry (vector-ref vector i)))
- (if (if (pair? entry)
- (memq name entry)
- (eq? name entry))
- i
- (loop (1+ i))))))
- (loop 0))))
-
-(define (microcode-table-ref slot index)
- (let ((vector (vector-ref fixed-objects slot)))
- (and (< index (vector-length vector))
- (let ((entry (vector-ref vector index)))
- (if (pair? entry)
- (car entry)
- entry)))))
-\f
-;;;; Microcode Type Codes
-
-(define types-slot)
-
-(define renamed-user-object-types
- '((FIXNUM . NUMBER)
- (BIGNUM . NUMBER)
- (FLONUM . NUMBER)
- (COMPLEX . NUMBER)
- (INTERNED-SYMBOL . SYMBOL)
- (UNINTERNED-SYMBOL . SYMBOL)
- (EXTENDED-PROCEDURE . PROCEDURE)
- (COMPILED-PROCEDURE . PROCEDURE)
- (PRIMITIVE . PRIMITIVE-PROCEDURE)
- (PRIMITIVE-EXTERNAL . PRIMITIVE-PROCEDURE)
- (LEXPR . LAMBDA)
- (EXTENDED-LAMBDA . LAMBDA)
- (COMBINATION-1 . COMBINATION)
- (COMBINATION-2 . COMBINATION)
- (PRIMITIVE-COMBINATION-0 . COMBINATION)
- (PRIMITIVE-COMBINATION-1 . COMBINATION)
- (PRIMITIVE-COMBINATION-2 . COMBINATION)
- (PRIMITIVE-COMBINATION-3 . COMBINATION)
- (SEQUENCE-2 . SEQUENCE)
- (SEQUENCE-3 . SEQUENCE)))
-
-(set! microcode-type-name
-(named-lambda (microcode-type-name type)
- (microcode-table-ref types-slot type)))
-
-(set! microcode-type
-(named-lambda (microcode-type name)
- (or (microcode-table-search types-slot name)
- (error "MICROCODE-TYPE: Unknown name" name))))
-
-(set! microcode-type-predicate
-(named-lambda (microcode-type-predicate name)
- (type-predicate (microcode-type name))))
-
-(define ((type-predicate type) object)
- (primitive-type? type object))
-
-(set! object-type
-(named-lambda (object-type object)
- (let ((type (microcode-type-name (primitive-type object))))
- (let ((entry (assq type renamed-user-object-types)))
- (if (not (null? entry))
- (cdr entry)
- type)))))
-\f
-;;;; Microcode Return Codes
-
-(define returns-slot)
-(define return-address-type)
-
-(set! microcode-return
-(named-lambda (microcode-return name)
- (microcode-table-search returns-slot name)))
-
-(set! make-return-address
-(named-lambda (make-return-address code)
- (map-code-to-machine-address return-address-type code)))
-
-(set! return-address?
-(named-lambda (return-address? object)
- (primitive-type? return-address-type object)))
-
-(set! return-address-code
-(named-lambda (return-address-code return-address)
- (map-machine-address-to-code return-address-type return-address)))
-
-(set! return-address-name
-(named-lambda (return-address-name return-address)
- (microcode-table-ref returns-slot (return-address-code return-address))))
-
-;;;; Microcode Error Codes
-
-(define errors-slot)
-
-(set! microcode-error
-(named-lambda (microcode-error name)
- (microcode-table-search errors-slot name)))
-
-;;;; Microcode Termination Codes
-
-(define termination-vector-slot)
-
-(set! microcode-termination
-(named-lambda (microcode-termination name)
- (microcode-table-search termination-vector-slot name)))
-
-(set! microcode-termination-name
-(named-lambda (microcode-termination-name type)
- (code->name termination-vector-slot type)))
-
-(define identification-vector-slot)
-
-(set! microcode-identification-item
- (lambda (name)
- (vector-ref :identification
- (or (microcode-table-search identification-vector-slot name)
- (error "Unknown identification item" name)))))
-\f
-;;;; Microcode Primitives
-
-(define primitives-slot)
-(define primitive-type-code)
-(define external-type-code)
-
-(set! primitive-procedure?
-(named-lambda (primitive-procedure? object)
- (or (primitive-type? primitive-type-code object)
- (primitive-type? external-type-code object))))
-
-(set! make-primitive-procedure
-(named-lambda (make-primitive-procedure name #!optional force?)
- (let ((code (name->code primitives-slot 'PRIMITIVE name)))
- (if code
- (map-code-to-machine-address primitive-type-code code)
- (or (get-external-number name (if (unassigned? force?) #f force?))
- (error "MAKE-PRIMITIVE-PROCEDURE: Unknown name" name))))))
-
-(set! implemented-primitive-procedure?
-(named-lambda (implemented-primitive-procedure? object)
- (cond ((primitive-type? primitive-type-code object) true)
- ((primitive-type? external-type-code object)
- (get-external-number (external-code->name (primitive-datum object))
- false))
- (else
- (error "Not a primitive procedure" implemented-primitive-procedure?
- object)))))
-
-(set! primitive-procedure-name
-(named-lambda (primitive-procedure-name primitive-procedure)
- (cond ((primitive-type? primitive-type-code primitive-procedure)
- (code->name primitives-slot
- 'PRIMITIVE
- (map-machine-address-to-code primitive-type-code
- primitive-procedure)))
- ((primitive-type? external-type-code primitive-procedure)
- (external-code->name (primitive-datum primitive-procedure)))
- (else
- (error "Not a primitive procedure" primitive-procedure-name
- primitive-procedure)))))
-\f
-(define (name->code slot type name)
- (or (and (pair? name)
- (eq? (car name) type)
- (pair? (cdr name))
- (let ((x (cdr name)))
- (and (integer? (car x))
- (not (negative? (car x)))
- (null? (cdr x))
- (car x))))
- (microcode-table-search slot name)))
-
-(define (code->name slot type code)
- (or (and (not (negative? code))
- (microcode-table-ref slot code))
- (list type code)))
-
-(define (external-code->name code)
- (let ((current-counts (get-external-counts)))
- (cond ((< code (car current-counts)) (get-external-name code))
- ((< code (+ (car current-counts) (cdr current-counts)))
- (get-external-name code)) ;Maybe should warn about undefined
- (else
- (error "Not an external procedure name" external-code->name
- code)))))
-\f
-;;;; Initialization
-
-(define microcode-tables-identification)
-
-(define (snarf-version)
- (set! :identification (microcode-identify))
-
- (set! microcode-tables-identification
- (scode-eval (binary-fasload (microcode-tables-filename))
- system-global-environment))
-
- (set! fixed-objects (get-fixed-objects-vector))
-
- (set! types-slot (fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR))
- (set! number-of-microcode-types
- (vector-length (vector-ref fixed-objects types-slot)))
-
- (set! returns-slot (fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR))
- (set! return-address-type (microcode-type 'RETURN-ADDRESS))
- (set! number-of-microcode-returns
- (vector-length (vector-ref fixed-objects returns-slot)))
-
- (set! errors-slot (fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR))
- (set! number-of-microcode-errors
- (vector-length (vector-ref fixed-objects errors-slot)))
-
- (set! primitives-slot
- (fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR))
- (set! primitive-type-code (microcode-type 'PRIMITIVE))
-
- (set! external-type-code (microcode-type 'PRIMITIVE-EXTERNAL))
-
- (set! termination-vector-slot
- (fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR))
- (set! number-of-microcode-terminations
- (vector-length (vector-ref fixed-objects termination-vector-slot)))
-
- (set! identification-vector-slot
- (fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR))
- (set! :release (microcode-identification-item 'SYSTEM-RELEASE-STRING))
- (set! :version (microcode-identification-item 'MICROCODE-VERSION))
- (set! :modification (microcode-identification-item 'MICROCODE-MODIFICATION))
-
- ;; Predicate to test if object is a future without touching it.
- (set! future?
- (let ((primitive (make-primitive-procedure 'FUTURE? true)))
- (if (implemented-primitive-procedure? primitive)
- primitive
- (lambda (object) false)))))
-
-(snarf-version)
-
-;;; end MICROCODE-SYSTEM.
-))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/vector.scm,v 13.42 1987/03/17 18:55:01 cph Exp $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Operations on Vectors
-
-(declare (usual-integrations))
-\f
-;;; Standard Procedures
-
-(in-package system-global-environment
-(let-syntax ()
- (define-macro (define-primitives . names)
- `(BEGIN ,@(map (lambda (name)
- `(DEFINE ,name ,(make-primitive-procedure name)))
- names)))
- (define-primitives
- vector-length vector-ref vector-set!
- list->vector vector-cons subvector->list)))
-
-(let-syntax ()
- (define-macro (define-type-predicate name type-name)
- `(DEFINE (,name OBJECT)
- (PRIMITIVE-TYPE? ,(microcode-type type-name) OBJECT)))
- (define-type-predicate vector? vector))
-
-(define (make-vector size #!optional fill)
- (if (unassigned? fill) (set! fill false))
- (vector-cons size fill))
-
-(define (vector . elements)
- (list->vector elements))
-
-(define (vector->list vector)
- (subvector->list vector 0 (vector-length vector)))
-
-(define (vector-fill! vector value)
- (subvector-fill! vector 0 (vector-length vector) value))
-\f
-;;; Nonstandard Primitives
-
-(let-syntax ((check-type
- (let ((type (microcode-type 'VECTOR)))
- (macro (object)
- `(IF (NOT (PRIMITIVE-TYPE? ,type ,object))
- (ERROR "Wrong type argument" ,object)))))
- (check-target
- (macro (object index)
- `(BEGIN (CHECK-TYPE ,object)
- (IF (NOT (AND (NOT (NEGATIVE? ,index))
- (<= ,index (VECTOR-LENGTH ,object))))
- (ERROR "Index out of range" ,index)))))
- (check-subvector
- (macro (object start end)
- `(BEGIN (CHECK-TYPE ,object)
- (IF (NOT (AND (NOT (NEGATIVE? ,start))
- (<= ,start ,end)
- (<= ,end (VECTOR-LENGTH ,object))))
- (ERROR "Indices out of range" ,start ,end))))))
-
-(define (subvector-move-right! vector1 start1 end1 vector2 start2)
- (define (loop index1 index2)
- (if (<= start1 index1)
- (begin (vector-set! vector2 index2 (vector-ref vector1 index1))
- (loop (-1+ index1) (-1+ index2)))))
- (check-subvector vector1 start1 end1)
- (check-target vector2 start2)
- (loop (-1+ end1) (-1+ (+ start2 (- end1 start1)))))
-
-(define (subvector-move-left! vector1 start1 end1 vector2 start2)
- (define (loop index1 index2)
- (if (< index1 end1)
- (begin (vector-set! vector2 index2 (vector-ref vector1 index1))
- (loop (1+ index1) (1+ index2)))))
- (check-subvector vector1 start1 end1)
- (check-target vector2 start2)
- (loop start1 start2))
-
-(define (subvector-fill! vector start end value)
- (define (loop index)
- (if (< index end)
- (begin (vector-set! vector index value)
- (loop (1+ index)))))
- (check-subvector vector start end)
- (loop start))
-
-)
-\f
-;;; Nonstandard Procedures
-
-(define (vector-copy vector)
- (let ((length (vector-length vector)))
- (let ((new-vector (make-vector length)))
- (subvector-move-right! vector 0 length new-vector 0)
- new-vector)))
-
-(define (make-initialized-vector length initialization)
- (let ((vector (make-vector length)))
- (define (loop n)
- (if (= n length)
- vector
- (begin (vector-set! vector n (initialization n))
- (loop (1+ n)))))
- (loop 0)))
-
-(define (vector-map vector procedure)
- (let ((length (vector-length vector)))
- (if (zero? length)
- vector
- (let ((result (make-vector length)))
- (define (loop i)
- (vector-set! result i (procedure (vector-ref vector i)))
- (if (zero? i)
- result
- (loop (-1+ i))))
- (loop (-1+ length))))))
-
-(define (vector-grow vector length)
- (let ((new-vector (make-vector length)))
- (subvector-move-right! vector 0 (vector-length vector) new-vector 0)
- new-vector))
-
-(define (vector-first vector) (vector-ref vector 0))
-(define (vector-second vector) (vector-ref vector 1))
-(define (vector-third vector) (vector-ref vector 2))
-(define (vector-fourth vector) (vector-ref vector 3))
-(define (vector-fifth vector) (vector-ref vector 4))
-(define (vector-sixth vector) (vector-ref vector 5))
-(define (vector-seventh vector) (vector-ref vector 6))
-(define (vector-eighth vector) (vector-ref vector 7))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 13.42 1987/03/17 18:55:18 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Environment Inspector
-
-(in-package debugger-package
-
-(declare (usual-integrations))
-
-(define env-package
- (let ((env)
- (current-frame)
- (current-frame-depth)
- (env-commands (make-command-set 'WHERE-COMMANDS)))
-\f
-(define (define-where-command letter function help-text)
- (define-letter-command env-commands letter function help-text))
-
-;;; Basic Commands
-
-(define-where-command #\? (standard-help-command env-commands)
- "Help, list command letters")
-
-(define-where-command #\Q standard-exit-command
- "Quit (exit from Where)")
-
-;;; Lexpr since it can take one or no arguments
-
-(define (where #!optional env-spec)
- (if (unassigned? env-spec) (set! env-spec (rep-environment)))
- (let ((environment
- (cond ((or (eq? env-spec system-global-environment)
- (environment? env-spec))
- env-spec)
- ((compound-procedure? env-spec)
- (procedure-environment env-spec))
- ((delayed? env-spec)
- (if (delayed-evaluation-forced? env-spec)
- (error "Not a valid environment, already forced"
- (list where env-spec))
- (delayed-evaluation-environment env-spec)))
- (else
- (error "Not a legal environment object" 'WHERE
- env-spec)))))
- (environment-warning-hook environment)
- (fluid-let ((env environment)
- (current-frame environment)
- (current-frame-depth 0))
- (letter-commands env-commands
- (standard-rep-message "Environment Inspector")
- (standard-rep-prompt "Where-->")))))
-\f
-;;;; Display Commands
-
-(define (show)
- (show-frame current-frame current-frame-depth))
-
-(define (show-all)
- (let s1 ((env env)
- (depth 0))
- (if (eq? system-global-environment env)
- *the-non-printing-object*
- (begin (show-frame env depth)
- (if (environment-has-parent? env)
- (s1 (environment-parent env) (1+ depth))
- *the-non-printing-object*)))))
-
-(define (show-frame frame depth)
- (if (eq? system-global-environment frame)
- (begin (newline)
- (write-string "This frame is the system global environment"))
- (begin (newline) (write-string "Frame created by ")
- (print-user-friendly-name frame)
- (if (>= depth 0)
- (begin (newline)
- (write-string "Depth (relative to starting frame): ")
- (write depth)))
- (newline)
- (let ((bindings (environment-bindings frame)))
- (if (null? bindings)
- (write-string "Has no bindings")
- (begin (write-string "Has bindings:")
- (newline)
- (for-each print-binding bindings))))))
- (newline))
-
-(define print-user-friendly-name
- (let ((rename-list
- `((,lambda-tag:unnamed . LAMBDA)
- (,(access internal-lambda-tag lambda-package) . LAMBDA)
- (,(access internal-lexpr-tag lambda-package) . LAMBDA)
- (,lambda-tag:let . LET)
- (,lambda-tag:shallow-fluid-let . FLUID-LET)
- (,lambda-tag:deep-fluid-let . FLUID-LET)
- (,lambda-tag:common-lisp-fluid-let . FLUID-BIND)
- (,lambda-tag:make-environment . MAKE-ENVIRONMENT))))
- (lambda (frame)
- (let ((name (environment-name frame)))
- (let ((rename (assq name rename-list)))
- (if rename
- (begin (write-string "a ")
- (write (cdr rename))
- (write-string " special form"))
- (begin (write-string "the procedure ")
- (write name))))))))
-\f
-(define (print-binding binding)
- (define line-width 79)
- (define name-width 40)
- (define (truncate str length)
- (set-string-length! str (- length 4))
- (string-append str " ..."))
- (newline)
- (let ((s (write-to-string (car binding) name-width)))
- (if (car s) ; Name was truncated
- (set! s (truncate (cdr s) name-width))
- (set! s (cdr s)))
- (if (null? (cdr binding))
- (set! s (string-append s " is unassigned"))
- (let ((s1 (write-to-string (cadr binding)
- (- line-width (string-length s)))))
- (set! s (string-append s " = " (cdr s1)));
- (if (car s1) ; Value truncated
- (set! s (truncate s line-width)))))
- (write-string s)))
-
-(define-where-command #\C show
- "Display the bindings in the current frame")
-
-(define-where-command #\A show-all
- "Display the bindings of all the frames in the current chain")
-\f
-;;;; Motion Commands
-
-(define (parent)
- (cond ((eq? system-global-environment current-frame)
- (newline)
- (write-string
-"The current frame is the system global environment, it has no parent."))
- ((environment-has-parent? current-frame)
- (set! current-frame (environment-parent current-frame))
- (set! current-frame-depth (1+ current-frame-depth))
- (show))
- (else
- (newline)
- (write-string "The current frame has no parent."))))
-
-
-(define (son)
- (cond ((eq? current-frame env)
- (newline)
- (write-string "This is the original frame. Its children cannot be found."))
- (else
- (let son-1 ((prev env)
- (prev-depth 0)
- (next (environment-parent env)))
- (if (eq? next current-frame)
- (begin (set! current-frame prev)
- (set! current-frame-depth prev-depth))
- (son-1 next
- (1+ prev-depth)
- (environment-parent next))))
- (show))))
-
-(define (recursive-where)
- (write-string "; Object to eval and examine-> ")
- (let ((inp (read)))
- (write-string "New where!")
- (where (eval inp current-frame))))
-
-(define-where-command #\P parent
- "Find the parent frame of the current one")
-
-(define-where-command #\S son
- "Find the son of the current environment in the current chain")
-
-(define-where-command #\W recursive-where
- "Eval an expression in the current frame and do WHERE on it")
-\f
-;;;; Relative Evaluation Commands
-
-(define (show-object)
- (write-string "; Object to eval and print-> ")
- (let ((inp (read)))
- (newline)
- (write (eval inp current-frame))
- (newline)))
-
-(define (enter)
- (read-eval-print current-frame
- "You are now in the desired environment"
- "Eval-in-env-->"))
-
-(define-where-command #\V show-object
- "Eval an expression in the current frame and print the result")
-
-(define-where-command #\E enter
- "Create a read-eval-print loop in the current environment")
-
-;;;; Miscellaneous Commands
-
-(define (name)
- (newline)
- (write-string "This frame was created by ")
- (print-user-friendly-name current-frame))
-
-(define-where-command #\N name
- "Name of procedure which created current environment")
-
-;;; end ENV-PACKAGE.
-(the-environment)))
-
-(define print-user-friendly-name
- (access print-user-friendly-name env-package))
-
-;;; end IN-PACKAGE DEBUGGER-PACKAGE.
-)
-
-;;;; Exports
-
-(define where
- (access where env-package debugger-package))
\ No newline at end of file
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/wind.scm,v 13.42 1987/02/15 15:46:23 cph Rel $
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; State Space Model
-
-(declare (usual-integrations)
- (integrate-primitive-procedures set-fixed-objects-vector!))
-\f
-(vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'STATE-SPACE-TAG)
- "State Space")
-
-(vector-set! (get-fixed-objects-vector)
- (fixed-objects-vector-slot 'STATE-POINT-TAG)
- "State Point")
-
-(set-fixed-objects-vector! (get-fixed-objects-vector))
-
-(define make-state-space
- (let ((prim (make-primitive-procedure 'MAKE-STATE-SPACE)))
- (named-lambda (make-state-space #!optional mutable?)
- (if (unassigned? mutable?) (set! mutable? #T))
- (prim mutable?))))
-
-(define execute-at-new-state-point
- (make-primitive-procedure 'EXECUTE-AT-NEW-STATE-POINT))
-
-(define translate-to-state-point
- (make-primitive-procedure 'TRANSLATE-TO-STATE-POINT))
-
-;;; The following code implements the current model of DYNAMIC-WIND as
-;;; a special case of the more general concept.
-
-(define system-state-space
- (make-state-space #F))
-
-(define current-dynamic-state
- (let ((prim (make-primitive-procedure 'current-dynamic-state)))
- (named-lambda (current-dynamic-state #!optional state-space)
- (prim (if (unassigned? state-space)
- system-state-space
- state-space)))))
-
-(define set-current-dynamic-state!
- (make-primitive-procedure 'set-current-dynamic-state!))
-
-;; NOTICE that the "before" thunk is executed IN THE NEW STATE,
-;; the "after" thunk is executed IN THE OLD STATE. It is hard to
-;; imagine why anyone would care about this.
-
-(define (dynamic-wind before during after)
- (execute-at-new-state-point system-state-space
- before
- during
- after))
-
-;; This is so the microcode can find the base state point.
-
-(let ((fov (get-fixed-objects-vector)))
- (vector-set! fov
- (fixed-objects-vector-slot 'STATE-SPACE-ROOT)
- (current-dynamic-state))
- (set-fixed-objects-vector! fov))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/cgen.scm,v 3.3 1987/03/20 23:49:11 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Generate SCode from Expression
-
-(declare (usual-integrations))
-\f
-(define (cgen/external quotation)
- (fluid-let ((flush-declarations? true))
- (cgen/top-level quotation)))
-
-(define (cgen/external-with-declarations expression)
- (fluid-let ((flush-declarations? false))
- (cgen/expression (list false) expression)))
-
-(define (cgen/top-level quotation)
- (let ((block (quotation/block quotation))
- (expression (quotation/expression quotation)))
- (cgen/declaration (block/declarations block)
- (cgen/expression (list block) expression))))
-
-(define (cgen/declaration declarations expression)
- (let ((declarations (maybe-flush-declarations declarations)))
- (if (null? declarations)
- expression
- (make-declaration declarations expression))))
-
-(define flush-declarations?)
-
-(define (maybe-flush-declarations declarations)
- (if (null? declarations)
- '()
- (let ((declarations (declarations/original declarations)))
- (if flush-declarations?
- (begin (for-each (lambda (declaration)
- (if (not (declarations/known? declaration))
- (warn "Unused declaration" declaration)))
- declarations)
- '())
- declarations))))
-
-(define (cgen/expressions interns expressions)
- (map (lambda (expression)
- (cgen/expression interns expression))
- expressions))
-
-(define (cgen/expression interns expression)
- ((expression/method dispatch-vector expression) interns expression))
-
-(define dispatch-vector
- (expression/make-dispatch-vector))
-
-(define define-method/cgen
- (expression/make-method-definer dispatch-vector))
-
-(define (cgen/variable interns variable)
- (cdr (or (assq variable (cdr interns))
- (let ((association
- (cons variable (make-variable (variable/name variable)))))
- (set-cdr! interns (cons association (cdr interns)))
- association))))
-\f
-(define-method/cgen 'ACCESS
- (lambda (interns expression)
- (make-access (cgen/expression interns (access/environment expression))
- (access/name expression))))
-
-(define-method/cgen 'ASSIGNMENT
- (lambda (interns expression)
- (make-assignment-from-variable
- (cgen/variable interns (assignment/variable expression))
- (cgen/expression interns (assignment/value expression)))))
-
-(define-method/cgen 'COMBINATION
- (lambda (interns expression)
- (make-combination
- (cgen/expression interns (combination/operator expression))
- (cgen/expressions interns (combination/operands expression)))))
-
-(define-method/cgen 'CONDITIONAL
- (lambda (interns expression)
- (make-conditional
- (cgen/expression interns (conditional/predicate expression))
- (cgen/expression interns (conditional/consequent expression))
- (cgen/expression interns (conditional/alternative expression)))))
-
-(define-method/cgen 'CONSTANT
- (lambda (interns expression)
- (constant/value expression)))
-
-(define-method/cgen 'DECLARATION
- (lambda (interns expression)
- (cgen/declaration (declaration/declarations expression)
- (cgen/expression interns
- (declaration/expression expression)))))
-
-(define-method/cgen 'DELAY
- (lambda (interns expression)
- (make-delay (cgen/expression interns (delay/expression expression)))))
-
-(define-method/cgen 'DISJUNCTION
- (lambda (interns expression)
- (make-disjunction
- (cgen/expression interns (disjunction/predicate expression))
- (cgen/expression interns (disjunction/alternative expression)))))
-
-(define-method/cgen 'IN-PACKAGE
- (lambda (interns expression)
- (make-in-package
- (cgen/expression interns (in-package/environment expression))
- (cgen/top-level (in-package/quotation expression)))))
-\f
-(define-method/cgen 'PROCEDURE
- (lambda (interns procedure)
- (make-lambda* (procedure/name procedure)
- (map variable/name (procedure/required procedure))
- (map variable/name (procedure/optional procedure))
- (let ((rest (procedure/rest procedure)))
- (and rest (variable/name rest)))
- (let ((block (procedure/block procedure)))
- (make-open-block
- '()
- (maybe-flush-declarations (block/declarations block))
- (cgen/expression (list block)
- (procedure/body procedure)))))))
-
-(define-method/cgen 'OPEN-BLOCK
- (lambda (interns expression)
- (let ((block (open-block/block expression)))
- (make-open-block '()
- (maybe-flush-declarations (block/declarations block))
- (cgen/body (list block) expression)))))
-
-(define (cgen/body interns open-block)
- (make-sequence
- (let loop
- ((variables (open-block/variables open-block))
- (values (open-block/values open-block))
- (actions (open-block/actions open-block)))
- (cond ((null? variables) (cgen/expressions interns actions))
- ((null? actions) (error "Extraneous auxiliaries"))
- ((eq? (car actions) open-block/value-marker)
- (cons (make-definition (variable/name (car variables))
- (cgen/expression interns (car values)))
- (loop (cdr variables) (cdr values) (cdr actions))))
- (else
- (cons (cgen/expression interns (car actions))
- (loop variables values (cdr actions))))))))
-
-(define-method/cgen 'QUOTATION
- (lambda (interns expression)
- (make-quotation (cgen/top-level expression))))
-
-(define-method/cgen 'REFERENCE
- (lambda (interns expression)
- (cgen/variable interns (reference/variable expression))))
-
-(define-method/cgen 'SEQUENCE
- (lambda (interns expression)
- (make-sequence (cgen/expressions interns (sequence/actions expression)))))
-
-(define-method/cgen 'THE-ENVIRONMENT
- (lambda (interns expression)
- (make-the-environment)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/chtype.scm,v 1.1 1987/03/21 00:23:49 cph Rel $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Intern object types
-
-(declare (usual-integrations))
-\f
-(define (change-type/external block expression)
- (change-type/block block)
- (change-type/expression expression)
- (return-2 expression (block/bound-variables block)))
-
-(define (change-type/block block)
- (change-type/object enumeration/random block)
- (for-each (lambda (variable)
- (change-type/object enumeration/random variable))
- (block/bound-variables block))
- (for-each change-type/block (block/children block)))
-
-(define (change-type/expressions expressions)
- (for-each change-type/expression expressions))
-
-(define (change-type/expression expression)
- (change-type/object enumeration/expression expression)
- ((expression/method dispatch-vector expression) expression))
-
-(define dispatch-vector
- (expression/make-dispatch-vector))
-
-(define define-method/change-type
- (expression/make-method-definer dispatch-vector))
-
-(define (change-type/object enumeration object)
- (object/set-enumerand!
- object
- (enumeration/name->enumerand enumeration
- (enumerand/name (object/enumerand object)))))
-
-(define-method/change-type 'ACCESS
- (lambda (expression)
- (change-type/expression (access/environment expression))))
-
-(define-method/change-type 'ASSIGNMENT
- (lambda (expression)
- (change-type/expression (assignment/value expression))))
-
-(define-method/change-type 'COMBINATION
- (lambda (expression)
- (change-type/expression (combination/operator expression))
- (change-type/expressions (combination/operands expression))))
-
-(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
- (lambda (expression)
- 'DONE))
-\f
-(define-method/change-type 'DECLARATION
- (lambda (expression)
- (change-type/expression (declaration/expression expression))))
-
-(define-method/change-type 'DELAY
- (lambda (expression)
- (change-type/expression (delay/expression expression))))
-
-(define-method/change-type 'DISJUNCTION
- (lambda (expression)
- (change-type/expression (disjunction/predicate expression))
- (change-type/expression (disjunction/alternative expression))))
-
-(define-method/change-type 'IN-PACKAGE
- (lambda (expression)
- (change-type/expression (in-package/environment expression))
- (change-type/quotation (in-package/quotation expression))))
-
-(define-method/change-type 'PROCEDURE
- (lambda (expression)
- (change-type/expression (procedure/body expression))))
-
-(define-method/change-type 'OPEN-BLOCK
- (lambda (expression)
- (change-type/expressions (open-block/values expression))
- (change-type/expressions (open-block/actions expression))))
-
-(define-method/change-type 'QUOTATION
- (lambda (expression)
- (change-type/quotation expression)))
-
-(define (change-type/quotation quotation)
- (change-type/expression (quotation/expression quotation)))
-
-(define-method/change-type 'REFERENCE
- (lambda (expression)
- 'DONE))
-
-(define-method/change-type 'SEQUENCE
- (lambda (expression)
- (change-type/expressions (sequence/actions expression))))
-
-(define-method/change-type 'THE-ENVIRONMENT
- (lambda (expression)
- 'DONE))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/copy.scm,v 3.3 1987/03/20 23:49:22 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Copy Expression
-
-(declare (usual-integrations))
-\f
-(define root-block)
-
-(define (copy/external/intern block expression uninterned)
- (fluid-let ((root-block block)
- (copy/variable/free copy/variable/free/intern)
- (copy/declarations copy/declarations/intern))
- (copy/expression root-block
- (environment/rebind block (environment/make) uninterned)
- expression)))
-
-(define (copy/external/extern expression)
- (fluid-let ((root-block (block/make false false))
- (copy/variable/free copy/variable/free/extern)
- (copy/declarations copy/declarations/extern))
- (let ((expression
- (copy/expression root-block (environment/make) expression)))
- (return-2 root-block expression))))
-
-(define (copy/expressions block environment expressions)
- (map (lambda (expression)
- (copy/expression block environment expression))
- expressions))
-
-(define (copy/expression block environment expression)
- ((expression/method dispatch-vector expression)
- block environment expression))
-
-(define dispatch-vector
- (expression/make-dispatch-vector))
-
-(define define-method/copy
- (expression/make-method-definer dispatch-vector))
-
-(define (copy/quotation quotation)
- (fluid-let ((root-block false))
- (let ((block (quotation/block quotation)))
- (quotation/make block
- (copy/expression block
- (environment/make)
- (quotation/expression quotation))))))
-\f
-(define (copy/block parent environment block)
- (let ((result (block/make parent (block/safe? block)))
- (old-bound (block/bound-variables block)))
- (let ((new-bound
- (map (lambda (variable)
- (variable/make result (variable/name variable)))
- old-bound)))
- (let ((environment (environment/bind environment old-bound new-bound)))
- (block/set-bound-variables! result new-bound)
- (block/set-declarations!
- result
- (copy/declarations block environment (block/declarations block)))
- (return-2 result environment)))))
-
-(define copy/variable/free)
-
-(define (copy/variable block environment variable)
- (environment/lookup environment variable
- identity-procedure
- (copy/variable/free variable)))
-
-(define (copy/variable/free/intern variable)
- (lambda ()
- (let ((name (variable/name variable)))
- (let loop ((block root-block))
- (let ((variable* (variable/assoc name (block/bound-variables block))))
- (cond ((eq? variable variable*)
- variable)
- ((not (block/parent block))
- (error "Unable to find free variable during copy" name))
- ((not variable*)
- (loop (block/parent block)))
- ((block/safe? (variable/block variable*))
- (variable/set-name! variable* (rename-symbol name))
- (loop (block/parent block)))
- (else
- (error "Integration requires renaming unsafe variable"
- name))))))))
-
-(define (rename-symbol symbol)
- (string->uninterned-symbol (symbol->string symbol)))
-
-(define (copy/variable/free/extern variable)
- (lambda ()
- (block/lookup-name root-block (variable/name variable))))
-\f
-(define copy/declarations)
-
-(define (copy/declarations/intern block environment declarations)
- (if (null? declarations)
- '()
- (declarations/map declarations
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda () variable)))
- identity-procedure)))
-
-(define (copy/declarations/extern block environment declarations)
- (if (null? declarations)
- '()
- (declarations/map declarations
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda ()
- (block/lookup-name root-block variable))))
- (lambda (expression)
- (copy/expression block environment expression)))))
-
-(define (environment/make)
- '())
-
-(define (environment/bind environment variables values)
- (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-not)
- (let ((association (assq variable environment)))
- (if association
- (if-found (cdr association))
- (if-not))))
-
-(define (environment/rebind block environment variables)
- (environment/bind environment
- variables
- (map (lambda (variable)
- (block/lookup-name block (variable/name variable)))
- variables)))
-
-(define (make-renamer environment)
- (lambda (variable)
- (environment/lookup environment variable
- identity-procedure
- (lambda () (error "Missing variable during copy operation" variable)))))
-\f
-(define-method/copy 'ACCESS
- (lambda (block environment expression)
- (access/make (copy/expression block environment
- (access/environment expression))
- (access/name expression))))
-
-(define-method/copy 'ASSIGNMENT
- (lambda (block environment expression)
- (assignment/make
- block
- (copy/variable block environment (assignment/variable expression))
- (copy/expression block environment (assignment/value expression)))))
-
-(define-method/copy 'COMBINATION
- (lambda (block environment expression)
- (combination/make
- (copy/expression block environment (combination/operator expression))
- (copy/expressions block environment (combination/operands expression)))))
-
-(define-method/copy 'CONDITIONAL
- (lambda (block environment expression)
- (conditional/make
- (copy/expression block environment (conditional/predicate expression))
- (copy/expression block environment (conditional/consequent expression))
- (copy/expression block environment
- (conditional/alternative expression)))))
-
-(define-method/copy 'CONSTANT
- (lambda (block environment expression)
- expression))
-
-(define-method/copy 'DECLARATION
- (lambda (block environment expression)
- (declaration/make
- (copy/declarations block environment
- (declaration/declarations expression))
- (copy/expression block environment (declaration/expression expression)))))
-
-(define-method/copy 'DELAY
- (lambda (block environment expression)
- (delay/make
- (copy/expression block environment (delay/expression expression)))))
-
-(define-method/copy 'DISJUNCTION
- (lambda (block environment expression)
- (disjunction/make
- (copy/expression block environment (disjunction/predicate expression))
- (copy/expression block environment
- (disjunction/alternative expression)))))
-\f
-(define-method/copy 'IN-PACKAGE
- (lambda (block environment expression)
- (in-package/make
- (copy/expression block environment (in-package/environment expression))
- (copy/quotation (in-package/quotation expression)))))
-
-(define-method/copy 'PROCEDURE
- (lambda (block environment procedure)
- (transmit-values (copy/block block environment (procedure/block procedure))
- (lambda (block environment)
- (let ((rename (make-renamer environment)))
- (procedure/make block
- (procedure/name procedure)
- (map rename (procedure/required procedure))
- (map rename (procedure/optional procedure))
- (let ((rest (procedure/rest procedure)))
- (and rest (rename rest)))
- (copy/expression block environment
- (procedure/body procedure))))))))
-
-(define-method/copy 'OPEN-BLOCK
- (lambda (block environment expression)
- (transmit-values
- (copy/block block environment (open-block/block expression))
- (lambda (block environment)
- (open-block/make
- block
- (map (make-renamer environment) (open-block/variables expression))
- (copy/expressions block environment (open-block/values expression))
- (map (lambda (action)
- (if (eq? action open-block/value-marker)
- action
- (copy/expression block environment action)))
- (open-block/actions expression)))))))
-
-(define-method/copy 'QUOTATION
- (lambda (block environment expression)
- (copy/quotation expression)))
-
-(define-method/copy 'REFERENCE
- (lambda (block environment expression)
- (reference/make block
- (copy/variable block environment
- (reference/variable expression)))))
-
-(define-method/copy 'SEQUENCE
- (lambda (block environment expression)
- (sequence/make
- (copy/expressions block environment (sequence/actions expression)))))
-
-(define-method/copy 'THE-ENVIRONMENT
- (lambda (block environment expression)
- (error "Attempt to integrate expression containing (THE-ENVIRONMENT)")))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/emodel.scm,v 3.2 1987/03/13 04:12:19 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Environment Model
-
-(declare (usual-integrations))
-\f
-(define variable/assoc
- (association-procedure eq? variable/name))
-
-(define (block/unsafe! block)
- (if (block/safe? block)
- (begin (block/set-safe?! block false)
- (if (block/parent block)
- (block/unsafe! (block/parent block))))))
-
-(define (block/lookup-name block name)
- (let search ((block block))
- (or (variable/assoc name (block/bound-variables block))
- (let ((parent (block/parent block)))
- (if (not parent)
- (variable/make&bind! block name)
- (search parent))))))
-
-(define (block/lookup-names block names)
- (map (lambda (name)
- (block/lookup-name block name))
- names))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/free.scm,v 3.2 1987/03/13 04:12:30 cph Rel $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Free Variable Analysis
-
-(declare (usual-integrations))
-\f
-(define (free/expressions expressions)
- (if (null? expressions)
- eq?-set/null
- (eq?-set/union (free/expression (car expressions))
- (free/expressions (cdr expressions)))))
-
-(define (free/expression expression)
- ((expression/method dispatch-vector expression) expression))
-
-(define dispatch-vector
- (expression/make-dispatch-vector))
-
-(define define-method/free
- (expression/make-method-definer dispatch-vector))
-
-(define-method/free 'ACCESS
- (lambda (expression)
- (free/expression (access/environment expression))))
-
-(define-method/free 'ASSIGNMENT
- (lambda (expression)
- (eq?-set/adjoin (assignment/variable expression)
- (free/expression (assignment/value expression)))))
-
-(define-method/free 'COMBINATION
- (lambda (expression)
- (eq?-set/union (free/expression (combination/operator expression))
- (free/expressions (combination/operands expression)))))
-
-(define-method/free 'CONDITIONAL
- (lambda (expression)
- (eq?-set/union
- (free/expression (conditional/predicate expression))
- (eq?-set/union (free/expression (conditional/consequent expression))
- (free/expression (conditional/alternative expression))))))
-
-(define-method/free 'CONSTANT
- (lambda (expression)
- eq?-set/null))
-
-(define-method/free 'DECLARATION
- (lambda (expression)
- (free/expression (declaration/expression expression))))
-\f
-(define-method/free 'DELAY
- (lambda (expression)
- (free/expression (delay/expression expression))))
-
-(define-method/free 'DISJUNCTION
- (lambda (expression)
- (eq?-set/union (free/expression (disjunction/predicate expression))
- (free/expression (disjunction/alternative expression)))))
-
-(define-method/free 'IN-PACKAGE
- (lambda (expression)
- (free/expression (in-package/environment expression))))
-
-(define-method/free 'PROCEDURE
- (lambda (expression)
- (eq?-set/difference (free/expression (procedure/body expression))
- (block/bound-variables (procedure/block expression)))))
-
-(define-method/free 'OPEN-BLOCK
- (lambda (expression)
- (eq?-set/difference
- (eq?-set/union (free/expressions (open-block/values expression))
- (let loop ((actions (open-block/actions expression)))
- (cond ((null? actions) eq?-set/null)
- ((eq? (car actions) open-block/value-marker)
- (loop (cdr actions)))
- (else
- (eq?-set/union (free/expression (car actions))
- (loop (cdr actions)))))))
- (block/bound-variables (open-block/block expression)))))
-
-(define-method/free 'QUOTATION
- (lambda (expression)
- eq?-set/null))
-
-(define-method/free 'REFERENCE
- (lambda (expression)
- (eq?-set/singleton (reference/variable expression))))
-
-(define-method/free 'SEQUENCE
- (lambda (expression)
- (free/expressions (sequence/actions expression))))
-
-(define-method/free 'THE-ENVIRONMENT
- (lambda (expression)
- eq?-set/null))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/gconst.scm,v 3.0 1987/03/10 13:24:58 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Global Constants List
-
-(declare (usual-integrations))
-\f
-;;; This is a list of names that are bound in the global environment.
-;;; Normally the compiler will replace references to one of these
-;;; names with the value of that name, which is a constant.
-
-(define global-constant-objects
- '(TRUE FALSE SYSTEM-GLOBAL-ENVIRONMENT
-
- SCODE-EVAL FORCE WITH-THREADED-CONTINUATION
- SET-INTERRUPT-ENABLES! WITH-INTERRUPT-MASK WITH-INTERRUPTS-REDUCED
- GET-FIXED-OBJECTS-VECTOR WITH-HISTORY-DISABLED
- PRIMITIVE-PROCEDURE-ARITY NOT FALSE?
- STRING->SYMBOL ERROR-PROCEDURE
-
- ;; Environment
- LEXICAL-REFERENCE LEXICAL-ASSIGNMENT LOCAL-ASSIGNMENT
- LEXICAL-UNASSIGNED? LEXICAL-UNBOUND? LEXICAL-UNREFERENCEABLE?
-
- ;; Pointers
- EQ?
- PRIMITIVE-SET-TYPE MAKE-NON-POINTER-OBJECT
- PRIMITIVE-TYPE? PRIMITIVE-TYPE PRIMITIVE-DATUM
- OBJECT-DANGEROUS? MAKE-OBJECT-SAFE MAKE-OBJECT-DANGEROUS
-
- ;; Numbers
- ZERO? POSITIVE? NEGATIVE? 1+ -1+
- INTEGER-DIVIDE INTEGER-DIVIDE-QUOTIENT INTEGER-DIVIDE-REMAINDER
- TRUNCATE ROUND FLOOR CEILING
- SQRT EXP LOG SIN COS
-
- ;; Basic Compound Datatypes
- CONS PAIR? CAR CDR SET-CAR! SET-CDR! GENERAL-CAR-CDR
- NULL? LENGTH MEMQ ASSQ FIRST HEAD EMPTY-STREAM?
-
- VECTOR-CONS VECTOR-LENGTH VECTOR-REF VECTOR-SET!
- LIST->VECTOR SUBVECTOR->LIST
-
- ;; Strings
- STRING-ALLOCATE STRING? STRING-REF STRING-SET!
- STRING-LENGTH STRING-MAXIMUM-LENGTH SET-STRING-LENGTH!
- SUBSTRING=? SUBSTRING-CI=? SUBSTRING<?
- SUBSTRING-MOVE-RIGHT! SUBSTRING-MOVE-LEFT!
- SUBSTRING-FIND-NEXT-CHAR-IN-SET
- SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET
- SUBSTRING-MATCH-FORWARD SUBSTRING-MATCH-BACKWARD
- SUBSTRING-MATCH-FORWARD-CI SUBSTRING-MATCH-BACKWARD-CI
- SUBSTRING-UPCASE! SUBSTRING-DOWNCASE! STRING-HASH
-
- ;; Byte Vectors (actually, String/Character operations)
- VECTOR-8B-REF VECTOR-8B-SET! VECTOR-8B-FILL!
- VECTOR-8B-FIND-NEXT-CHAR VECTOR-8B-FIND-PREVIOUS-CHAR
- VECTOR-8B-FIND-NEXT-CHAR-CI VECTOR-8B-FIND-PREVIOUS-CHAR-CI
-
- BIT-STRING-ALLOCATE MAKE-BIT-STRING BIT-STRING?
- BIT-STRING-LENGTH BIT-STRING-REF BIT-STRING-CLEAR! BIT-STRING-SET!
- BIT-STRING-ZERO? BIT-STRING=?
- BIT-STRING-FILL! BIT-STRING-MOVE! BIT-STRING-MOVEC!
- BIT-STRING-OR! BIT-STRING-AND! BIT-STRING-ANDC!
- BIT-SUBSTRING-MOVE-RIGHT!
- BIT-STRING->UNSIGNED-INTEGER UNSIGNED-INTEGER->BIT-STRING
- READ-BITS! WRITE-BITS!
-
- MAKE-CELL CELL? CELL-CONTENTS SET-CELL-CONTENTS!
-
- ;; Characters
- MAKE-CHAR CHAR-CODE CHAR-BITS
- CHAR-ASCII? ASCII->CHAR CHAR->ASCII
- INTEGER->CHAR CHAR->INTEGER
- CHAR-UPCASE CHAR-DOWNCASE
-
- ;; System Compound Datatypes
- SYSTEM-PAIR-CONS SYSTEM-PAIR?
- SYSTEM-PAIR-CAR SYSTEM-PAIR-SET-CAR!
- SYSTEM-PAIR-CDR SYSTEM-PAIR-SET-CDR!
-
- SYSTEM-HUNK3-CXR0 SYSTEM-HUNK3-SET-CXR0!
- SYSTEM-HUNK3-CXR1 SYSTEM-HUNK3-SET-CXR1!
- SYSTEM-HUNK3-CXR2 SYSTEM-HUNK3-SET-CXR2!
-
- SYSTEM-LIST-TO-VECTOR SYSTEM-SUBVECTOR-TO-LIST SYSTEM-VECTOR?
- SYSTEM-VECTOR-SIZE SYSTEM-VECTOR-REF SYSTEM-VECTOR-SET!
- ))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/make.scm,v 3.4 1987/03/20 23:50:32 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: System Construction
-
-(in-package system-global-environment
-(declare (usual-integrations))
-\f
-(define sf)
-(define sf/set-file-syntax-table!)
-(define sf/add-file-declarations!)
-(load "$zcomp/base/load" system-global-environment)
-
-(load-system system-global-environment
- 'PACKAGE/SCODE-OPTIMIZER
- '(SYSTEM-GLOBAL-ENVIRONMENT)
- '(
- (PACKAGE/SCODE-OPTIMIZER
- "mvalue" ;Multiple Value Support
- "eqsets" ;Set Data Abstraction
-
- "object" ;Data Structures
- "emodel" ;Environment Model
- "gconst" ;Global Primitives List
- "usicon" ;Usual Integrations: Constants
- "tables" ;Table Abstractions
- "packag" ;Global packaging
- )
-
- (PACKAGE/TOP-LEVEL
- "toplev" ;Top Level
- )
-
- (PACKAGE/TRANSFORM
- "xform" ;SCode -> Internal
- )
-
- (PACKAGE/INTEGRATE
- "subst" ;Beta Substitution Optimizer
- )
-
- (PACKAGE/CGEN
- "cgen" ;Internal -> SCode
- )
-
- (PACKAGE/EXPANSION
- "usiexp" ;Usual Integrations: Expanders
- )
-
- (PACKAGE/DECLARATIONS
- "pardec" ;Declaration Parser
- )
-
- (PACKAGE/COPY
- "copy" ;Copy Expressions
- )
-
- (PACKAGE/FREE
- "free" ;Free Variable Analysis
- )
-
- (PACKAGE/SAFE?
- "safep" ;Safety Analysis
- )
-
- (PACKAGE/CHANGE-TYPE
- "chtype" ;Type interning
- )
-
- ))
-\f
-(in-package package/scode-optimizer
- (define integrations
- "$zcomp/source/object")
-
- (define scode-optimizer/system
- (make-environment
- (define :name "SF")
- (define :version 3)
- (define :modification 3)))
-
- (add-system! scode-optimizer/system)
-
- (scode-optimizer/initialize!))
-
-;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/object.scm,v 3.1 1987/03/13 04:12:53 cph Rel $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Data Types
-
-(declare (usual-integrations))
-\f
-(let-syntax ()
-
-(define-syntax define-type
- (macro (name enumeration slots)
- (let ((enumerand (symbol-append name '/ENUMERAND)))
- `(BEGIN
- (DEFINE ,enumerand
- (ENUMERATION/NAME->ENUMERAND ,(symbol-append 'ENUMERATION/
- enumeration)
- ',name))
- ((ACCESS ADD-UNPARSER-SPECIAL-OBJECT! UNPARSER-PACKAGE) ,enumerand
- (LAMBDA (OBJECT)
- (UNPARSE-WITH-BRACKETS
- (LAMBDA ()
- (WRITE ',name)
- (WRITE-STRING " ")
- (WRITE (HASH OBJECT))))))
- (DEFINE ,(symbol-append name '?) (OBJECT/PREDICATE ,enumerand))
- ,@(let loop ((slots slots) (index 1))
- (if (null? slots)
- '()
- (let ((slot (car slots)))
- (let ((ref-name (symbol-append name '/ slot))
- (set-name (symbol-append name '/SET- slot '!)))
- `((DECLARE (INTEGRATE-OPERATOR ,ref-name ,set-name))
- (DEFINE (,ref-name ,name)
- (DECLARE (INTEGRATE ,name))
- (VECTOR-REF ,name ,index))
- (DEFINE (,set-name ,name ,slot)
- (DECLARE (INTEGRATE ,name ,slot))
- (VECTOR-SET! ,name ,index ,slot))
- ,@(loop (cdr slots) (1+ index)))))))))))
-
-(define-syntax define-simple-type
- (macro (name enumeration slots)
- (let ((make-name (symbol-append name '/MAKE)))
- `(BEGIN (DECLARE (INTEGRATE-OPERATOR ,make-name))
- (DEFINE (,make-name ,@slots)
- (DECLARE (INTEGRATE ,@slots))
- (OBJECT/ALLOCATE ,(symbol-append name '/ENUMERAND) ,@slots))
- (DEFINE-TYPE ,name ,enumeration ,slots)))))
-\f
-;;;; Objects
-
-(declare (integrate object/allocate)
- (integrate-operator object/enumerand object/set-enumerand!))
-
-(define object/allocate vector)
-
-(define (object/enumerand object)
- (declare (integrate object))
- (vector-ref object 0))
-
-(define (object/set-enumerand! object enumerand)
- (declare (integrate object enumerand))
- (vector-set! object 0 enumerand))
-
-(define (object/predicate enumerand)
- (lambda (object)
- (and (vector? object)
- (not (zero? (vector-length object)))
- (eq? enumerand (vector-ref object 0)))))
-\f
-;;;; Enumerations
-
-(define (enumeration/make names)
- (let ((enumerands
- (let loop ((names names) (index 0))
- (if (null? names)
- '()
- (cons (vector false (car names) index)
- (loop (cdr names) (1+ index)))))))
- (let ((enumeration
- (cons (list->vector enumerands)
- (map (lambda (enumerand)
- (cons (enumerand/name enumerand) enumerand))
- enumerands))))
- (for-each (lambda (enumerand)
- (vector-set! enumerand 0 enumeration))
- enumerands)
- enumeration)))
-
-(declare (integrate-operator enumerand/enumeration enumerand/name
- enumerand/index enumeration/cardinality
- enumeration/index->enumerand))
-
-(define (enumerand/enumeration enumerand)
- (declare (integrate enumerand))
- (vector-ref enumerand 0))
-
-(define (enumerand/name enumerand)
- (declare (integrate enumerand))
- (vector-ref enumerand 1))
-
-(define (enumerand/index enumerand)
- (declare (integrate enumerand))
- (vector-ref enumerand 2))
-
-(define (enumeration/cardinality enumeration)
- (declare (integrate enumeration))
- (vector-length (car enumeration)))
-
-(define (enumeration/index->enumerand enumeration index)
- (declare (integrate enumeration index))
- (vector-ref (car enumeration) index))
-
-(define (enumeration/name->enumerand enumeration name)
- (cdr (or (assq name (cdr enumeration))
- (error "Unknown enumeration name" name))))
-
-(define (enumeration/name->index enumeration name)
- (enumerand/index (enumeration/name->enumerand enumeration name)))
-\f
-;;;; Random Types
-
-(define enumeration/random
- (enumeration/make
- '(BLOCK
- DELAYED-INTEGRATION
- VARIABLE
- )))
-
-(define-type block random
- (parent children safe? declarations bound-variables))
-
-(define (block/make parent safe?)
- (let ((block
- (object/allocate block/enumerand parent '() safe?
- (declarations/make-null) '())))
- (if parent
- (block/set-children! parent (cons block (block/children parent))))
- block))
-
-(define-type delayed-integration random
- (state environment operations value))
-
-(declare (integrate-operator delayed-integration/make))
-
-(define (delayed-integration/make operations expression)
- (declare (integrate operations expression))
- (object/allocate delayed-integration/enumerand 'NOT-INTEGRATED false
- operations expression))
-
-(define-simple-type variable random
- (block name))
-
-(define (variable/make&bind! block name)
- (let ((variable (variable/make block name)))
- (block/set-bound-variables! block
- (cons variable
- (block/bound-variables block)))
- variable))
-
-(define open-block/value-marker
- ;; This must be an interned object because we will fasdump it and
- ;; fasload it back in.
- (make-named-tag "open-block/value-marker"))
-\f
-;;;; Expression Types
-
-(define enumeration/expression
- (enumeration/make
- '(ACCESS
- ASSIGNMENT
- COMBINATION
- CONDITIONAL
- CONSTANT
- DECLARATION
- DELAY
- DISJUNCTION
- IN-PACKAGE
- OPEN-BLOCK
- PROCEDURE
- QUOTATION
- REFERENCE
- SEQUENCE
- THE-ENVIRONMENT
- )))
-
-(define (expression/make-dispatch-vector)
- (make-vector (enumeration/cardinality enumeration/expression)))
-
-(define (expression/make-method-definer dispatch-vector)
- (lambda (type-name method)
- (vector-set! dispatch-vector
- (enumeration/name->index enumeration/expression type-name)
- method)))
-
-(declare (integrate-operator expression/method name->method))
-
-(define (expression/method dispatch-vector expression)
- (declare (integrate dispatch-vector expression))
- (vector-ref dispatch-vector (enumerand/index (object/enumerand expression))))
-
-(define (name->method dispatch-vector name)
- ;; Useful for debugging
- (declare (integrate dispatch-vector name))
- (vector-ref dispatch-vector
- (enumeration/name->index enumeration/expression name)))
-\f
-(define-simple-type access expression (environment name))
-(define-simple-type assignment expression (block variable value))
-(define-simple-type combination expression (operator operands))
-(define-simple-type conditional expression (predicate consequent alternative))
-(define-simple-type constant expression (value))
-(define-simple-type declaration expression (declarations expression))
-(define-simple-type delay expression (expression))
-(define-simple-type disjunction expression (predicate alternative))
-(define-simple-type in-package expression (environment quotation))
-(define-simple-type open-block expression (block variables values actions))
-(define-simple-type procedure expression
- (block name required optional rest body))
-(define-simple-type quotation expression (block expression))
-(define-simple-type reference expression (block variable))
-(define-simple-type sequence expression (actions))
-(define-simple-type the-environment expression (block))
-
-;;; end LET-SYNTAX
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/pardec.scm,v 3.3 1987/03/19 17:19:06 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Parse Declarations
-
-(declare (usual-integrations))
-\f
-(define (declarations/make-null)
- (declarations/make '() '() '()))
-
-(define (declarations/parse block declarations)
- (transmit-values
- (accumulate
- (lambda (declaration bindings)
- (let ((association (assq (car declaration) known-declarations)))
- (if (not association)
- bindings
- (transmit-values (cdr association)
- (lambda (before-bindings? parser)
- (let ((block
- (if before-bindings?
- (let ((block (block/parent block)))
- (if (block/parent block)
- (warn "Declaration not at top level"
- declaration))
- block)
- block)))
- (parser block
- (bindings/cons block before-bindings?)
- bindings
- (cdr declaration))))))))
- (return-2 '() '())
- declarations)
- (lambda (before after)
- (declarations/make declarations before after))))
-
-(define (bindings/cons block before-bindings?)
- (lambda (bindings global? operation export? names values)
- (let ((result
- (binding/make global? operation export?
- (if global? names (block/lookup-names block names))
- values)))
- (transmit-values bindings
- (lambda (before after)
- (if before-bindings?
- (return-2 (cons result before) after)
- (return-2 before (cons result after))))))))
-
-(define (bind/values table/cons table operation export? names values)
- (table/cons table (not export?) operation export? names values))
-
-(define (bind/no-values table/cons table operation export? names)
- (table/cons table false operation export? names 'NO-VALUES))
-\f
-(define (declarations/known? declaration)
- (assq (car declaration) known-declarations))
-
-(define (define-declaration name before-bindings? parser)
- (let ((entry (assq name known-declarations)))
- (if entry
- (set-cdr! entry (return-2 before-bindings? parser))
- (set! known-declarations
- (cons (cons name (return-2 before-bindings? parser))
- known-declarations)))))
-
-(define known-declarations
- '())
-
-(define (accumulate cons table items)
- (let loop ((table table) (items items))
- (if (null? items)
- table
- (loop (cons (car items) table) (cdr items)))))
-\f
-(define (declarations/binders declarations)
- (let ((procedure
- (lambda (bindings)
- (lambda (operations)
- (accumulate (lambda (binding operations)
- ((if (binding/global? binding)
- operations/bind-global
- operations/bind)
- operations
- (binding/operation binding)
- (binding/export? binding)
- (binding/names binding)
- (binding/values binding)))
- operations
- bindings)))))
- (return-2 (procedure (declarations/before declarations))
- (procedure (declarations/after declarations)))))
-
-(define (declarations/for-each-variable declarations procedure)
- (declarations/for-each-binding declarations
- (lambda (binding)
- (if (not (binding/global? binding))
- (for-each procedure (binding/names binding))))))
-
-(define (declarations/for-each-binding declarations procedure)
- (let ((procedure
- (lambda (bindings)
- (for-each procedure bindings))))
- (procedure (declarations/before declarations))
- (procedure (declarations/after declarations))))
-
-(define (declarations/map declarations per-name per-value)
- (declarations/map-binding declarations
- (lambda (binding)
- (let ((global? (binding/global? binding))
- (names (binding/names binding))
- (values (binding/values binding)))
- (binding/make global?
- (binding/operation binding)
- (binding/export? binding)
- (if global? names (map per-name names))
- (if (eq? values 'NO-VALUES)
- values
- (map per-value values)))))))
-
-(define (declarations/map-binding declarations procedure)
- (let ((procedure
- (lambda (bindings)
- (map procedure bindings))))
- (declarations/make (declarations/original declarations)
- (procedure (declarations/before declarations))
- (procedure (declarations/after declarations)))))
-\f
-(declare (integrate-operator declarations/make declarations/original
- declarations/before declarations/after))
-
-(define (declarations/make original before after)
- (declare (integrate original before after))
- (vector original before after))
-
-(define (declarations/original declarations)
- (declare (integrate declarations))
- (vector-ref declarations 0))
-
-(define (declarations/before declarations)
- (declare (integrate declarations))
- (vector-ref declarations 1))
-
-(define (declarations/after declarations)
- (declare (integrate declarations))
- (vector-ref declarations 2))
-
-(declare (integrate-operator binding/make binding/global? binding/operation
- binding/export? binding/names binding/values))
-
-(define (binding/make global? operation export? names values)
- (declare (integrate global? operation export? names values))
- (vector global? operation export? names values))
-
-(define (binding/global? binding)
- (declare (integrate binding))
- (vector-ref binding 0))
-
-(define (binding/operation binding)
- (declare (integrate binding))
- (vector-ref binding 1))
-
-(define (binding/export? binding)
- (declare (integrate binding))
- (vector-ref binding 2))
-
-(define (binding/names binding)
- (declare (integrate binding))
- (vector-ref binding 3))
-
-(define (binding/values binding)
- (declare (integrate binding))
- (vector-ref binding 4))
-\f
-;;;; Integration of System Constants
-
-(define-declaration 'USUAL-INTEGRATIONS true
- (lambda (block table/cons table deletions)
- (let ((finish
- (lambda (table operation names values)
- (transmit-values
- (if (null? deletions)
- (return-2 names values)
- (let deletion-loop ((names names) (values values))
- (cond ((null? names) (return-2 '() '()))
- ((memq (car names) deletions)
- (deletion-loop (cdr names) (cdr values)))
- (else
- (cons-multiple
- (return-2 (car names) (car values))
- (deletion-loop (cdr names) (cdr values)))))))
- (lambda (names values)
- (bind/values table/cons table operation false names
- values))))))
- (finish (finish table 'INTEGRATE
- usual-integrations/constant-names
- usual-integrations/constant-values)
- 'EXPAND
- usual-integrations/expansion-names
- usual-integrations/expansion-values))))
-
-(define-declaration 'INTEGRATE-PRIMITIVE-PROCEDURES false
- (lambda (block table/cons table specifications)
- (transmit-values
- (let loop ((specifications specifications))
- (if (null? specifications)
- (return-2 '() '())
- (cons-multiple (parse-primitive-specification
- block
- (car specifications))
- (loop (cdr specifications)))))
- (lambda (names values)
- (bind/values table/cons table 'INTEGRATE true names values)))))
-
-(define (parse-primitive-specification block specification)
- (let ((finish
- (lambda (variable-name primitive-name)
- (return-2 variable-name
- (constant->integration-info
- (make-primitive-procedure primitive-name))))))
- (cond ((and (pair? specification)
- (symbol? (car specification))
- (pair? (cdr specification))
- (symbol? (cadr specification))
- (null? (cddr specification)))
- (finish (first specification) (second specification)))
- ((symbol? specification) (finish specification specification))
- (else (error "Bad primitive specification" specification)))))
-\f
-;;;; Integration of User Code
-
-(define-declaration 'INTEGRATE false
- (lambda (block table/cons table names)
- (bind/no-values table/cons table 'INTEGRATE true names)))
-
-(define-declaration 'INTEGRATE-OPERATOR false
- (lambda (block table/cons table names)
- (bind/no-values table/cons table 'INTEGRATE-OPERATOR true names)))
-
-(define-declaration 'INTEGRATE-EXTERNAL true
- (lambda (block table/cons table specifications)
- (accumulate
- (lambda (extern table)
- (bind/values table/cons table (vector-ref extern 1) false
- (list (vector-ref extern 0))
- (list
- (intern-type (vector-ref extern 2)
- (vector-ref extern 3)))))
- table
- (mapcan read-externs-file
- (mapcan specification->pathnames specifications)))))
-
-(define (specification->pathnames specification)
- (let ((value
- (scode-eval (syntax specification system-global-syntax-table)
- (access syntax-environment syntaxer-package))))
- (if (pair? value)
- (map ->pathname value)
- (list (->pathname value)))))
-
-(define (operations->external operations environment)
- (operations/extract-external operations
- (lambda (variable operation info if-ok if-not)
- (let ((finish
- (lambda (value)
- (if-ok
- (transmit-values (copy/expression/extern value)
- (lambda (block expression)
- (vector (variable/name variable)
- operation
- block
- expression)))))))
- (if info
- (transmit-values info
- (lambda (value uninterned)
- (finish value)))
- (variable/final-value variable environment finish if-not))))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/subst.scm,v 3.3 1987/03/20 23:49:33 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Beta Substitution
-
-(declare (usual-integrations))
-\f
-(define (integrate/top-level block expression)
- (let ((operations (operations/bind-block (operations/make) block))
- (environment (environment/make)))
- (if (open-block? expression)
- (transmit-values
- (environment/recursive-bind operations environment
- (open-block/variables expression)
- (open-block/values expression))
- (lambda (environment values)
- (return-3 operations
- environment
- (quotation/make block
- (integrate/open-block operations
- environment
- expression
- values)))))
- (return-3 operations
- environment
- (quotation/make block
- (integrate/expression operations
- environment
- expression))))))
-
-(define (operations/bind-block operations block)
- (let ((declarations (block/declarations block)))
- (if (null? declarations)
- (operations/shadow operations (block/bound-variables block))
- (transmit-values (declarations/binders declarations)
- (lambda (before-bindings after-bindings)
- (after-bindings
- (operations/shadow (before-bindings operations)
- (block/bound-variables block))))))))
-
-(define (integrate/expressions operations environment expressions)
- (map (lambda (expression)
- (integrate/expression operations environment expression))
- expressions))
-
-(define (integrate/expression operations environment expression)
- ((expression/method dispatch-vector expression)
- operations environment expression))
-
-(define dispatch-vector
- (expression/make-dispatch-vector))
-
-(define define-method/integrate
- (expression/make-method-definer dispatch-vector))
-\f
-;;;; Lookup
-
-(define-method/integrate 'REFERENCE
- (lambda (operations environment expression)
- (operations/lookup operations (reference/variable expression)
- (lambda (operation info)
- (case operation
- ((INTEGRATE-OPERATOR EXPAND) expression)
- ((INTEGRATE) (integrate/name expression info environment))
- (else (error "Unknown operation" operation))))
- (lambda () expression))))
-
-(define (integrate/reference-operator operations environment operator operands)
- (let ((dont-integrate
- (lambda ()
- (combination/make operator operands))))
- (operations/lookup operations (reference/variable operator)
- (lambda (operation info)
- (case operation
- ((#F) (dont-integrate))
- ((INTEGRATE INTEGRATE-OPERATOR)
- (integrate/combination operations
- environment
- (integrate/name operator info environment)
- operands))
- ((EXPAND)
- (info operands
- identity-procedure ;expanded value can't be optimized further.
- dont-integrate))
- (else (error "Unknown operation" operation))))
- dont-integrate)))
-
-(define-method/integrate 'ASSIGNMENT
- (lambda (operations environment assignment)
- (let ((variable (assignment/variable assignment)))
- (operations/lookup operations variable
- (lambda (operation info)
- (case operation
- ((INTEGRATE INTEGRATE-OPERATOR EXPAND)
- (warn "Attempt to assign integrated name"
- (variable/name variable)))
- (else (error "Unknown operation" operation))))
- (lambda () 'DONE))
- (assignment/make (assignment/block assignment)
- variable
- (integrate/expression operations
- environment
- (assignment/value assignment))))))
-\f
-;;;; Binding
-
-(define-method/integrate 'OPEN-BLOCK
- (lambda (operations environment expression)
- (let ((operations
- (operations/bind-block operations (open-block/block expression))))
- (transmit-values
- (environment/recursive-bind operations
- environment
- (open-block/variables expression)
- (open-block/values expression))
- (lambda (environment values)
- (integrate/open-block operations
- environment
- expression
- values))))))
-
-(define (integrate/open-block operations environment expression values)
- (open-block/make (open-block/block expression)
- (open-block/variables expression)
- values
- (map (lambda (action)
- (if (eq? action open-block/value-marker)
- action
- (integrate/expression operations
- environment
- action)))
- (open-block/actions expression))))
-
-(define (integrate/procedure operations environment procedure)
- (let ((block (procedure/block procedure)))
- (procedure/make block
- (procedure/name procedure)
- (procedure/required procedure)
- (procedure/optional procedure)
- (procedure/rest procedure)
- (integrate/expression (operations/bind-block operations
- block)
- environment
- (procedure/body procedure)))))
-
-(define-method/integrate 'PROCEDURE
- integrate/procedure)
-\f
-(define-method/integrate 'COMBINATION
- (lambda (operations environment combination)
- (integrate/combination
- operations
- environment
- (combination/operator combination)
- (integrate/expressions operations
- environment
- (combination/operands combination)))))
-
-(define (integrate/combination operations environment operator operands)
- (if (reference? operator)
- (integrate/reference-operator operations
- environment
- operator
- operands)
- (combination/optimizing-make
- (if (procedure? operator)
- (integrate/procedure-operator operations
- environment
- operator
- operands)
- (let ((operator
- (integrate/expression operations environment operator)))
- (if (procedure? operator)
- (integrate/procedure-operator operations
- environment
- operator
- operands)
- operator)))
- operands)))
-
-(define (integrate/procedure-operator operations environment procedure
- operands)
- (integrate/procedure operations
- (simulate-application environment procedure operands)
- procedure))
-
-(define-method/integrate 'DECLARATION
- (lambda (operations environment declaration)
- (let ((declarations (declaration/declarations declaration)))
- (declaration/make
- declarations
- (transmit-values (declarations/binders declarations)
- (lambda (before-bindings after-bindings)
- (integrate/expression (after-bindings (before-bindings operations))
- environment
- (declaration/expression declaration))))))))
-\f
-;;;; Easy Cases
-
-(define-method/integrate 'CONSTANT
- (lambda (operations environment expression)
- expression))
-
-(define-method/integrate 'THE-ENVIRONMENT
- (lambda (operations environment expression)
- expression))
-
-(define-method/integrate 'QUOTATION
- (lambda (operations environment expression)
- (integrate/quotation expression)))
-
-(define-method/integrate 'CONDITIONAL
- (lambda (operations environment expression)
- (conditional/make
- (integrate/expression operations environment
- (conditional/predicate expression))
- (integrate/expression operations environment
- (conditional/consequent expression))
- (integrate/expression operations environment
- (conditional/alternative expression)))))
-
-(define-method/integrate 'DISJUNCTION
- (lambda (operations environment expression)
- (disjunction/make
- (integrate/expression operations environment
- (disjunction/predicate expression))
- (integrate/expression operations environment
- (disjunction/alternative expression)))))
-\f
-(define-method/integrate 'SEQUENCE
- (lambda (operations environment expression)
- (sequence/make
- (integrate/expressions operations environment
- (sequence/actions expression)))))
-
-(define-method/integrate 'ACCESS
- (lambda (operations environment expression)
- (access/make (integrate/expression operations environment
- (access/environment expression))
- (access/name expression))))
-
-(define-method/integrate 'DELAY
- (lambda (operations environment expression)
- (delay/make
- (integrate/expression operations environment
- (delay/expression expression)))))
-
-(define-method/integrate 'IN-PACKAGE
- (lambda (operations environment expression)
- (in-package/make (integrate/expression operations environment
- (in-package/environment expression))
- (integrate/quotation (in-package/quotation expression)))))
-
-(define (integrate/quotation quotation)
- (transmit-values (integrate/top-level (quotation/block quotation)
- (quotation/expression quotation))
- (lambda (operations environment expression)
- expression)))
-\f
-;;;; Environment
-
-(define (environment/recursive-bind operations environment variables values)
- ;; Used to implement mutually-recursive definitions that can
- ;; integrate one another. When circularities are detected within
- ;; the definition-reference graph, integration is disabled.
- (let ((values
- (map (lambda (value)
- (delayed-integration/make operations value))
- values)))
- (let ((environment
- (environment/bind-multiple environment variables values)))
- (for-each (lambda (value)
- (delayed-integration/set-environment! value environment))
- values)
- (return-2 environment
- (map delayed-integration/force values)))))
-
-(define (integrate/name reference info environment)
- (let ((variable (reference/variable reference)))
- (let ((finish
- (lambda (value uninterned)
- (copy/expression (reference/block reference) value uninterned))))
- (if info
- (transmit-values info finish)
- (environment/lookup environment variable
- (lambda (value)
- (if (delayed-integration? value)
- (if (delayed-integration/in-progress? value)
- reference
- (finish (delayed-integration/force value) '()))
- (finish value '())))
- (lambda () reference))))))
-
-(define (variable/final-value variable environment if-value if-not)
- (environment/lookup environment variable
- (lambda (value)
- (if (delayed-integration? value)
- (if (delayed-integration/in-progress? value)
- (error "Unfinished integration" value)
- (if-value (delayed-integration/force value)))
- (if-value value)))
- (lambda ()
- (warn "Unable to integrate" (variable/name variable))
- (if-not))))
-\f
-(define (simulate-application environment procedure operands)
-
- (define (match-required environment required operands)
- (cond ((null? required)
- (match-optional environment
- (procedure/optional procedure)
- operands))
- ((null? operands)
- (error "Too few operands in call to procedure" procedure))
- (else
- (match-required (environment/bind environment
- (car required)
- (car operands))
- (cdr required)
- (cdr operands)))))
-
- (define (match-optional environment optional operands)
- (cond ((null? optional)
- (match-rest environment (procedure/rest procedure) operands))
- ((null? operands)
- (match-rest environment (procedure/rest procedure) '()))
- (else
- (match-optional (environment/bind environment
- (car optional)
- (car operands))
- (cdr optional)
- (cdr operands)))))
-
- (define (match-rest environment rest operands)
- (cond (rest
- ;; Other cases are too hairy -- don't bother.
- (if (null? operands)
- (environment/bind environment rest (constant/make '()))
- environment))
- ((null? operands)
- environment)
- (else
- (error "Too many operands in call to procedure" procedure))))
-
- (match-required environment (procedure/required procedure) operands))
-\f
-(define (environment/make)
- '())
-
-(define (environment/bind environment variable value)
- (cons (cons variable value) environment))
-
-(define (environment/bind-multiple environment variables values)
- (map* environment cons variables values))
-
-(define (environment/lookup environment variable if-found if-not)
- (let ((association (assq variable environment)))
- (if association
- (if-found (cdr association))
- (if-not))))
-
-(define (delayed-integration/in-progress? delayed-integration)
- (eq? (delayed-integration/state delayed-integration) 'BEING-INTEGRATED))
-
-(define (delayed-integration/force delayed-integration)
- (case (delayed-integration/state delayed-integration)
- ((NOT-INTEGRATED)
- (let ((value
- (let ((environment
- (delayed-integration/environment delayed-integration))
- (operations
- (delayed-integration/operations delayed-integration))
- (expression (delayed-integration/value delayed-integration)))
- (delayed-integration/set-state! delayed-integration
- 'BEING-INTEGRATED)
- (delayed-integration/set-environment! delayed-integration false)
- (delayed-integration/set-operations! delayed-integration false)
- (delayed-integration/set-value! delayed-integration false)
- (integrate/expression operations environment expression))))
- (delayed-integration/set-state! delayed-integration 'INTEGRATED)
- (delayed-integration/set-value! delayed-integration value)))
- ((INTEGRATED) 'DONE)
- ((BEING-INTEGRATED)
- (error "Attempt to re-force delayed integration" delayed-integration))
- (else
- (error "Delayed integration has unknown state" delayed-integration)))
- (delayed-integration/value delayed-integration))
-\f
-;;;; Optimizations
-
-(define combination/optimizing-make)
-(let ()
-
-(set! combination/optimizing-make
- (lambda (operator operands)
- (if (and (procedure? operator)
- (null? (procedure/optional operator))
- (not (procedure/rest operator))
- (block/safe? (procedure/block operator))
- (not (open-block? (procedure/body operator))))
- ;; Simple LET-like combination. Delete any unreferenced
- ;; parameters. If no parameters remain, delete the
- ;; combination and lambda.
- (let ((body (procedure/body operator)))
- (transmit-values ((delete-unused-parameters (free/expression body))
- (procedure/required operator)
- operands)
- (lambda (required operands)
- (if (null? required)
- body
- (combination/make (procedure/make (procedure/block operator)
- (procedure/name operator)
- required '() false body)
- operands)))))
- (combination/make operator operands))))
-
-(define (delete-unused-parameters referenced)
- (define (loop parameters operands)
- (if (null? parameters)
- (return-2 '() operands)
- (let ((rest (loop (cdr parameters) (cdr operands))))
- (if (memq (car parameters) referenced)
- (transmit-values rest
- (lambda (parameters* operands*)
- (return-2 (cons (car parameters) parameters*)
- (cons (car operands) operands*))))
- rest))))
- loop)
-
-;;; end COMBINATION/OPTIMIZING-MAKE
-)
-\f
-#| This is too much of a pain to do now. Maybe later.
-
-(define procedure/optimizing-make)
-(let ()
-
-(set! procedure/optimizing-make
- (lambda (block name required optional rest auxiliary body)
- (if (and (not (null? auxiliary))
- optimize-open-blocks?
- (block/safe? block))
- (let ((used
- (used-auxiliaries (list-transform-positive auxiliary
- variable-value)
- (free/expression body))))
- (procedure/make block name required optional rest used
- (delete-unused-definitions used body)))
- (procedure/make block name required optional rest auxiliary body))))
-
-(define (delete-unused-definitions used body)
- ???)
-
-;;; A non-obvious program: (1) Collect all of the free references to
-;;; the block's bound variables which occur in the body of the block.
-;;; (2) Examine each of the values associated with that set of free
-;;; references, and add any new free references to the collection.
-;;; (3) Continue looping until no more free references are added.
-
-(define (used-auxiliaries auxiliary initial-used)
- (let ((used (eq?-set/intersection auxiliary initial-used)))
- (if (null? used)
- '()
- (let loop ((previous-used used) (new-used used))
- (for-each (lambda (value)
- (for-each (lambda (variable)
- (if (and (memq variable auxiliary)
- (not (memq variable used)))
- (set! used (cons variable used))))
- (free/expression value)))
- (map variable/value new-used))
- (let ((diffs
- (let note-diffs ((used used))
- (if (eq? used previous-used)
- '()
- (cons (cdar used)
- (note-diffs (cdr used)))))))
- (if (null? diffs)
- used
- (loop used diffs)))))))
-
-;;; end PROCEDURE/OPTIMIZING-MAKE
-)
-|#
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/tables.scm,v 3.1 1987/03/13 04:14:10 cph Rel $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Tables
-
-(declare (usual-integrations))
-\f
-;;;; Operations
-
-(define (operations/make)
- (cons '() '()))
-
-(define (operations/lookup operations variable if-found if-not)
- (let ((entry (assq variable (car operations)))
- (finish
- (lambda (entry)
- (if-found (vector-ref (cdr entry) 1)
- (vector-ref (cdr entry) 2)))))
- (if entry
- (if (cdr entry) (finish entry) (if-not))
- (let ((entry (assq (variable/name variable) (cdr operations))))
- (if entry (finish entry) (if-not))))))
-
-(define (operations/shadow operations variables)
- (cons (map* (car operations)
- (lambda (variable) (cons variable false))
- variables)
- (cdr operations)))
-
-(define (operations/bind-global operations operation export? names values)
- (cons (car operations)
- (map* (cdr operations)
- (lambda (name value)
- (cons name (vector export? operation value)))
- names values)))
-
-(define (operations/bind operations operation export? names values)
- (cons (let ((make-binding
- (lambda (name value)
- (cons name (vector export? operation value)))))
- (if (eq? values 'NO-VALUES)
- (map* (car operations)
- (lambda (name) (make-binding name false))
- names)
- (map* (car operations) make-binding names values)))
- (cdr operations)))
-
-(define (operations/extract-external operations procedure)
- (let loop ((elements (car operations)))
- (if (null? elements)
- '()
- (let ((value (cdar elements)) (rest (loop (cdr elements))))
- (if (and value (vector-ref value 0))
- (procedure (caar elements) (vector-ref value 1)
- (vector-ref value 2)
- (lambda (value) (cons value rest))
- (lambda () rest))
- rest)))))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Top Level
-
-(declare (usual-integrations))
-\f
-;;;; User Interface
-
-(define generate-unfasl-files? false
- "Set this non-false to cause unfasl files to be generated by default.")
-
-(define optimize-open-blocks? false
- "Set this non-false to eliminate unreferenced auxiliary definitions.
-Currently this optimization is not implemented.")
-
-(define (integrate/procedure procedure declarations)
- (if (compound-procedure? procedure)
- (procedure-components procedure
- (lambda (*lambda environment)
- (scode-eval (integrate/scode *lambda declarations false)
- environment)))
- (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
-
-(define (integrate/sexp s-expression syntax-table declarations receiver)
- (integrate/simple (lambda (s-expressions)
- (phase:syntax s-expressions syntax-table))
- (list s-expression) declarations receiver))
-
-(define (integrate/scode scode declarations receiver)
- (integrate/simple identity-procedure scode declarations receiver))
-
-(define (sf input-string #!optional bin-string spec-string)
- (if (unassigned? bin-string) (set! bin-string false))
- (if (unassigned? spec-string) (set! spec-string false))
- (syntax-file input-string bin-string spec-string))
-
-(define (scold input-string #!optional bin-string spec-string)
- "Use this only for syntaxing the cold-load root file.
-Currently only the 68000 implementation needs this."
- (if (unassigned? bin-string) (set! bin-string false))
- (if (unassigned? spec-string) (set! spec-string false))
- (fluid-let ((wrapping-hook wrap-with-control-point))
- (syntax-file input-string bin-string spec-string)))
-\f
-(define (sf/set-file-syntax-table! pathname syntax-table)
- (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
- (let ((association (find-file-info/assoc pathname)))
- (if association
- (set-cdr! association
- (transmit-values (cdr association)
- (lambda (ignore declarations)
- (return-2 syntax-table declarations))))
- (set! file-info
- (cons (cons pathname (return-2 syntax-table '()))
- file-info))))))
-
-(define (sf/add-file-declarations! pathname declarations)
- (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
- (let ((association (find-file-info/assoc pathname)))
- (if association
- (set-cdr! association
- (transmit-values (cdr association)
- (lambda (syntax-table declarations*)
- (return-2 syntax-table
- (append! declarations*
- (list-copy declarations))))))
- (set! file-info
- (cons (cons pathname (return-2 false declarations))
- file-info))))))
-
-(define file-info
- '())
-
-(define (find-file-info pathname)
- (let ((association
- (find-file-info/assoc (pathname->absolute-pathname pathname))))
- (if association
- (cdr association)
- (return-2 false '()))))
-
-(define (find-file-info/assoc pathname)
- (list-search-positive file-info
- (lambda (entry)
- (pathname=? (car entry) pathname))))
-
-(define (pathname=? x y)
- (and (equal? (pathname-device x) (pathname-device y))
- (equal? (pathname-directory x) (pathname-directory y))
- (equal? (pathname-name x) (pathname-name y))))
-\f
-;;;; File Syntaxer
-
-(define sf/default-input-pathname
- (make-pathname false false false "scm" 'NEWEST))
-
-(define sf/default-externs-pathname
- (make-pathname false false false "ext" 'NEWEST))
-
-(define sf/output-pathname-type "bin")
-(define sf/unfasl-pathname-type "unf")
-
-(define (syntax-file input-string bin-string spec-string)
- (let ((eval-sf-expression
- (lambda (input-string)
- (let ((input-path
- (pathname->input-truename
- (merge-pathnames (->pathname input-string)
- sf/default-input-pathname))))
- (if (not input-path)
- (error "SF: File does not exist" input-string))
- (let ((bin-path
- (let ((bin-path
- (pathname-new-type input-path
- sf/output-pathname-type)))
- (if bin-string
- (merge-pathnames (->pathname bin-string) bin-path)
- bin-path))))
- (let ((spec-path
- (and (or spec-string generate-unfasl-files?)
- (let ((spec-path
- (pathname-new-type bin-path
- sf/unfasl-pathname-type)))
- (if spec-string
- (merge-pathnames (->pathname spec-string)
- spec-path)
- spec-path)))))
- (syntax-file* input-path bin-path spec-path)))))))
- (if (list? input-string)
- (for-each (lambda (input-string)
- (eval-sf-expression input-string))
- input-string)
- (eval-sf-expression input-string)))
- *the-non-printing-object*)
-\f
-(define (syntax-file* input-pathname bin-pathname spec-pathname)
- (let ((start-date (date))
- (start-time (time))
- (input-filename (pathname->string input-pathname))
- (bin-filename (pathname->string bin-pathname))
- (spec-filename (and spec-pathname (pathname->string spec-pathname))))
- (newline)
- (write-string "Syntax file: ")
- (write input-filename)
- (write-string " ")
- (write bin-filename)
- (write-string " ")
- (write spec-filename)
- (transmit-values
- (transmit-values (find-file-info input-pathname)
- (lambda (syntax-table declarations)
- (integrate/file input-pathname syntax-table declarations
- spec-pathname)))
- (lambda (expression externs events)
- (fasdump (wrapping-hook
- (make-comment `((SOURCE-FILE . ,input-filename)
- (DATE . ,start-date)
- (TIME . ,start-time)
- (FLUID-LET . ,*fluid-let-type*))
- (set! expression false)))
- bin-pathname)
- (write-externs-file (pathname-new-type
- bin-pathname
- (pathname-type sf/default-externs-pathname))
- (set! externs false))
- (if spec-pathname
- (begin (newline)
- (write-string "Writing ")
- (write spec-filename)
- (with-output-to-file spec-pathname
- (lambda ()
- (newline)
- (write `(DATE ,start-date ,start-time))
- (newline)
- (write `(FLUID-LET ,*fluid-let-type*))
- (newline)
- (write `(SOURCE-FILE ,input-filename))
- (newline)
- (write `(BINARY-FILE ,bin-filename))
- (for-each (lambda (event)
- (newline)
- (write `(,(car event)
- (RUNTIME ,(cdr event)))))
- events)))
- (write-string " -- done")))))))
-\f
-(define (read-externs-file pathname)
- (let ((pathname
- (merge-pathnames (->pathname pathname) sf/default-externs-pathname)))
- (if (file-exists? pathname)
- (fasload pathname)
- (begin (warn "Nonexistent externs file" (pathname->string pathname))
- '()))))
-
-(define (write-externs-file pathname externs)
- (cond ((not (null? externs))
- (fasdump externs pathname))
- ((file-exists? pathname)
- (delete-file pathname))))
-
-(define (print-spec identifier names)
- (newline)
- (newline)
- (write-string "(")
- (write identifier)
- (let loop
- ((names
- (sort names
- (lambda (x y)
- (string<? (symbol->string x)
- (symbol->string y))))))
- (if (not (null? names))
- (begin (newline)
- (write (car names))
- (loop (cdr names)))))
- (write-string ")"))
-
-(define (wrapping-hook scode)
- scode)
-
-(define control-point-tail
- `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
- () () () () () () () () () () () () () () ()))
-
-(define (wrap-with-control-point scode)
- (system-list-to-vector type-code-control-point
- `(,return-address-restart-execution
- ,scode
- ,system-global-environment
- ,return-address-non-existent-continuation
- ,@control-point-tail)))
-
-(define type-code-control-point
- (microcode-type 'CONTROL-POINT))
-
-(define return-address-restart-execution
- (make-return-address (microcode-return 'RESTART-EXECUTION)))
-
-(define return-address-non-existent-continuation
- (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
-\f
-;;;; Optimizer Top Level
-
-(define (integrate/file file-name syntax-table declarations compute-free?)
- (integrate/kernel (lambda ()
- (phase:syntax (phase:read file-name) syntax-table))
- declarations))
-
-(define (integrate/simple preprocessor input declarations receiver)
- (transmit-values
- (integrate/kernel (lambda () (preprocessor input)) declarations)
- (or receiver
- (lambda (expression externs events)
- expression))))
-
-(define (integrate/kernel get-scode declarations)
- (fluid-let ((previous-time false)
- (previous-name false)
- (events '()))
- (transmit-values
- (transmit-values
- (transmit-values
- (phase:transform (canonicalize-scode (get-scode) declarations))
- phase:optimize)
- phase:generate-scode)
- (lambda (externs expression)
- (end-phase)
- (return-3 expression externs (reverse! events))))))
-
-(define (canonicalize-scode scode declarations)
- (let ((declarations
- ((access process-declarations syntaxer-package) declarations)))
- (if (null? declarations)
- scode
- (scan-defines (make-sequence
- (list (make-block-declaration declarations)
- scode))
- make-open-block))))
-\f
-(define (phase:read filename)
- (mark-phase "Read")
- (read-file filename))
-
-(define (phase:syntax s-expression #!optional syntax-table)
- (if (or (unassigned? syntax-table) (not syntax-table))
- (set! syntax-table (make-syntax-table system-global-syntax-table)))
- (mark-phase "Syntax")
- (syntax* s-expression syntax-table))
-
-(define (phase:transform scode)
- (mark-phase "Transform")
- (transform/expression scode))
-
-(define (phase:optimize block expression)
- (mark-phase "Optimize")
- (integrate/expression block expression))
-
-(define (phase:generate-scode operations environment expression)
- (mark-phase "Generate SCode")
- (return-2 (operations->external operations environment)
- (cgen/expression expression)))
-
-(define previous-time)
-(define previous-name)
-(define events)
-
-(define (mark-phase this-name)
- (end-phase)
- (newline)
- (write-string " ")
- (write-string this-name)
- (write-string "...")
- (set! previous-name this-name))
-
-(define (end-phase)
- (let ((this-time (runtime)))
- (if previous-time
- (let ((dt (- this-time previous-time)))
- (set! events (cons (cons previous-name dt) events))
- (newline)
- (write-string " Time: ")
- (write dt)
- (write-string " seconds.")))
- (set! previous-time this-time)))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usicon.scm,v 3.1 1987/03/13 04:14:39 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Usual Integrations: Constants
-
-(declare (usual-integrations))
-\f
-(define usual-integrations/constant-names)
-(define usual-integrations/constant-values)
-
-(define (usual-integrations/delete-constant! name)
- (set! global-constant-objects (delq! name global-constant-objects))
- (usual-integrations/cache!))
-
-(define (usual-integrations/cache!)
- (set! usual-integrations/constant-names
- (list-copy global-constant-objects))
- (set! usual-integrations/constant-values
- (map (lambda (name)
- (let ((object
- (lexical-reference system-global-environment name)))
- (if (not (scode-constant? object))
- (error "USUAL-INTEGRATIONS: not a constant" name))
- (constant->integration-info object)))
- usual-integrations/constant-names))
- 'DONE)
-
-(define (constant->integration-info constant)
- (return-2 (constant/make constant) '()))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/usiexp.scm,v 3.0 1987/03/10 13:25:31 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Usual Integrations: Combination Expansions
-
-(declare (usual-integrations))
-\f
-;;;; N-ary Arithmetic Predicates
-
-(define (make-combination primitive operands)
- (combination/make (constant/make primitive) operands))
-
-(define (constant-eq? expression constant)
- (and (constant? expression)
- (eq? (constant/value expression) constant)))
-
-(define (pairwise-test binary-predicate if-left-zero if-right-zero)
- (lambda (operands if-expanded if-not-expanded)
- (cond ((or (null? operands)
- (null? (cdr operands)))
- (error "Too few operands" operands))
- ((null? (cddr operands))
- (if-expanded
- (cond ((constant-eq? (car operands) 0)
- (make-combination if-left-zero (list (cadr operands))))
- ((constant-eq? (cadr operands) 0)
- (make-combination if-right-zero (list (car operands))))
- (else
- (make-combination binary-predicate operands)))))
- (else
- (if-not-expanded)))))
-
-(define (pairwise-test-inverse inverse-expansion)
- (lambda (operands if-expanded if-not-expanded)
- (inverse-expansion operands
- (lambda (expression)
- (if-expanded (make-combination not (list expression))))
- if-not-expanded)))
-
-(define =-expansion
- (pairwise-test (make-primitive-procedure '&=) zero? zero?))
-
-(define <-expansion
- (pairwise-test (make-primitive-procedure '&<) positive? negative?))
-
-(define >-expansion
- (pairwise-test (make-primitive-procedure '&>) negative? positive?))
-
-(define <=-expansion
- (pairwise-test-inverse >-expansion))
-
-(define >=-expansion
- (pairwise-test-inverse <-expansion))
-\f
-;;;; N-ary Arithmetic Field Operations
-
-(define (right-accumulation identity make-binary)
- (lambda (operands if-expanded if-not-expanded)
- (let ((operands (delq identity operands)))
- (let ((n (length operands)))
- (cond ((zero? n)
- (if-expanded (constant/make identity)))
- ((< n 5)
- (if-expanded
- (let loop
- ((first (car operands))
- (rest (cdr operands)))
- (if (null? rest)
- first
- (make-binary first
- (loop (car rest) (cdr rest)))))))
- (else
- (if-not-expanded)))))))
-
-(define +-expansion
- (right-accumulation 0
- (let ((&+ (make-primitive-procedure '&+)))
- (lambda (x y)
- (cond ((constant-eq? x 1) (make-combination 1+ (list y)))
- ((constant-eq? y 1) (make-combination 1+ (list x)))
- (else (make-combination &+ (list x y))))))))
-
-(define *-expansion
- (right-accumulation 1
- (let ((&* (make-primitive-procedure '&*)))
- (lambda (x y)
- (make-combination &* (list x y))))))
-\f
-(define (right-accumulation-inverse identity inverse-expansion make-binary)
- (lambda (operands if-expanded if-not-expanded)
- (let ((expand
- (lambda (x y)
- (if-expanded
- (if (constant-eq? y identity)
- x
- (make-binary x y))))))
- (cond ((null? operands)
- (error "Too few operands"))
- ((null? (cdr operands))
- (expand (constant/make identity) (car operands)))
- (else
- (inverse-expansion (cdr operands)
- (lambda (expression)
- (expand (car operands) expression))
- if-not-expanded))))))
-
-(define --expansion
- (right-accumulation-inverse 0 +-expansion
- (let ((&- (make-primitive-procedure '&-)))
- (lambda (x y)
- (if (constant-eq? y 1)
- (make-combination -1+ (list x))
- (make-combination &- (list x y)))))))
-
-(define /-expansion
- (right-accumulation-inverse 1 *-expansion
- (let ((&/ (make-primitive-procedure '&/)))
- (lambda (x y)
- (make-combination &/ (list x y))))))
-\f
-;;;; Miscellaneous Arithmetic
-
-(define (divide-component-expansion selector)
- (lambda (operands if-expanded if-not-expanded)
- (if-expanded
- (make-combination selector
- (list (make-combination integer-divide operands))))))
-
-(define quotient-expansion
- (divide-component-expansion car))
-
-(define remainder-expansion
- (divide-component-expansion cdr))
-\f
-;;;; N-ary List Operations
-
-(define apply*-expansion
- (let ((apply-primitive (make-primitive-procedure 'APPLY)))
- (lambda (operands if-expanded if-not-expanded)
- (let ((n (length operands)))
- (cond ((< n 2) (error "APPLY*-EXPANSION: Too few arguments" n))
- ((< n 10)
- (if-expanded
- (make-combination
- apply-primitive
- (list (car operands)
- (cons*-expansion-loop (cdr operands))))))
- (else (if-not-expanded)))))))
-
-(define (cons*-expansion operands if-expanded if-not-expanded)
- (let ((n (length operands)))
- (cond ((zero? n) (error "CONS*-EXPANSION: No arguments!"))
- ((< n 9) (if-expanded (cons*-expansion-loop operands)))
- (else (if-not-expanded)))))
-
-(define (cons*-expansion-loop rest)
- (if (null? (cdr rest))
- (car rest)
- (make-combination cons
- (list (car rest)
- (cons*-expansion-loop (cdr rest))))))
-
-(define (list-expansion operands if-expanded if-not-expanded)
- (if (< (length operands) 9)
- (if-expanded (list-expansion-loop operands))
- (if-not-expanded)))
-
-(define (vector-expansion operands if-expanded if-not-expanded)
- (if (< (length operands) 9)
- (if-expanded (make-combination list->vector
- (list (list-expansion-loop operands))))
- (if-not-expanded)))
-
-(define (list-expansion-loop rest)
- (if (null? rest)
- (constant/make '())
- (make-combination cons
- (list (car rest)
- (list-expansion-loop (cdr rest))))))
-\f
-;;;; General CAR/CDR Encodings
-
-(define (general-car-cdr-expansion encoding)
- (lambda (operands if-expanded if-not-expanded)
- (if (= (length operands) 1)
- (if-expanded
- (make-combination general-car-cdr
- (list (car operands)
- (constant/make encoding))))
- (error "Wrong number of arguments" (length operands)))))
-
-(define caar-expansion (general-car-cdr-expansion #b111))
-(define cadr-expansion (general-car-cdr-expansion #b110))
-(define cdar-expansion (general-car-cdr-expansion #b101))
-(define cddr-expansion (general-car-cdr-expansion #b100))
-
-(define caaar-expansion (general-car-cdr-expansion #b1111))
-(define caadr-expansion (general-car-cdr-expansion #b1110))
-(define cadar-expansion (general-car-cdr-expansion #b1101))
-(define caddr-expansion (general-car-cdr-expansion #b1100))
-(define cdaar-expansion (general-car-cdr-expansion #b1011))
-(define cdadr-expansion (general-car-cdr-expansion #b1010))
-(define cddar-expansion (general-car-cdr-expansion #b1001))
-(define cdddr-expansion (general-car-cdr-expansion #b1000))
-
-(define caaaar-expansion (general-car-cdr-expansion #b11111))
-(define caaadr-expansion (general-car-cdr-expansion #b11110))
-(define caadar-expansion (general-car-cdr-expansion #b11101))
-(define caaddr-expansion (general-car-cdr-expansion #b11100))
-(define cadaar-expansion (general-car-cdr-expansion #b11011))
-(define cadadr-expansion (general-car-cdr-expansion #b11010))
-(define caddar-expansion (general-car-cdr-expansion #b11001))
-(define cadddr-expansion (general-car-cdr-expansion #b11000))
-(define cdaaar-expansion (general-car-cdr-expansion #b10111))
-(define cdaadr-expansion (general-car-cdr-expansion #b10110))
-(define cdadar-expansion (general-car-cdr-expansion #b10101))
-(define cdaddr-expansion (general-car-cdr-expansion #b10100))
-(define cddaar-expansion (general-car-cdr-expansion #b10011))
-(define cddadr-expansion (general-car-cdr-expansion #b10010))
-(define cdddar-expansion (general-car-cdr-expansion #b10001))
-(define cddddr-expansion (general-car-cdr-expansion #b10000))
-
-(define second-expansion cadr-expansion)
-(define third-expansion caddr-expansion)
-(define fourth-expansion cadddr-expansion)
-(define fifth-expansion (general-car-cdr-expansion #b110000))
-(define sixth-expansion (general-car-cdr-expansion #b1100000))
-(define seventh-expansion (general-car-cdr-expansion #b11000000))
-(define eighth-expansion (general-car-cdr-expansion #b110000000))
-\f
-;;;; Miscellaneous
-
-(define (make-string-expansion operands if-expanded if-not-expanded)
- (let ((n (length operands)))
- (cond ((zero? n)
- (error "MAKE-STRING-EXPANSION: No arguments"))
- ((= n 1)
- (if-expanded (make-combination string-allocate operands)))
- (else
- (if-not-expanded)))))
-
-(define (identity-procedure-expansion operands if-expanded if-not-expanded)
- (if (not (= (length operands) 1))
- (error "IDENTITY-PROCEDURE-EXPANSION: wrong number of arguments"
- (length operands)))
- (if-expanded (car operands)))
-\f
-;;;; Tables
-
-(define usual-integrations/expansion-names
- '(= < > <= >= + - * / quotient remainder
- apply cons* list vector
- caar cadr cdar cddr
- caaar caadr cadar caddr cdaar cdadr cddar cdddr
- caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
- cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
- second third fourth fifth sixth seventh eighth
- make-string identity-procedure
- ))
-
-(define usual-integrations/expansion-values
- (list =-expansion <-expansion >-expansion <=-expansion >=-expansion
- +-expansion --expansion *-expansion /-expansion
- quotient-expansion remainder-expansion
- apply*-expansion cons*-expansion list-expansion vector-expansion
- caar-expansion cadr-expansion cdar-expansion cddr-expansion
- caaar-expansion caadr-expansion cadar-expansion caddr-expansion
- cdaar-expansion cdadr-expansion cddar-expansion cdddr-expansion
- caaaar-expansion caaadr-expansion caadar-expansion caaddr-expansion
- cadaar-expansion cadadr-expansion caddar-expansion cadddr-expansion
- cdaaar-expansion cdaadr-expansion cdadar-expansion cdaddr-expansion
- cddaar-expansion cddadr-expansion cdddar-expansion cddddr-expansion
- second-expansion third-expansion fourth-expansion fifth-expansion
- sixth-expansion seventh-expansion eighth-expansion
- make-string-expansion identity-procedure-expansion
- usual-integrations/expansion-values))
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/sf/xform.scm,v 3.3 1987/03/20 23:49:46 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Transform Input Expression
-
-(declare (usual-integrations))
-\f
-;;; GLOBAL-BLOCK is used to handle (USUAL-INTEGRATIONS), as follows.
-;;; This declaration refers to a large group of names, which are
-;;; normally defined in the global environment. Names in this group
-;;; are supposed to be shadowed by top-level definitions in the user's
-;;; program.
-
-;;; Normally we would intern the variable objects corresponding to
-;;; those names in the block corresponding to the outermost
-;;; environment in the user's program. However, if the user had a
-;;; top-level definition which was intended to shadow one of those
-;;; names, both the definition and the declaration would refer to the
-;;; same variable object. So, instead we intern them in GLOBAL-BLOCK,
-;;; which never has any user defined names in it.
-
-(define (transform/top-level expression)
- (let ((block (block/make (block/make false false) false)))
- (return-2 block (transform/top-level-1 block expression))))
-
-(define (transform/top-level-1 block expression)
- (fluid-let ((global-block
- (let block/global-parent ((block block))
- (if (block/parent block)
- (block/global-parent (block/parent block))
- block))))
- (let ((environment (environment/make)))
- (if (scode-open-block? expression)
- (open-block-components expression
- (transform/open-block* block environment))
- (transform/expression block environment expression)))))
-
-(define (transform/expressions block environment expressions)
- (map (lambda (expression)
- (transform/expression block environment expression))
- expressions))
-
-(define (transform/expression block environment expression)
- ((transform/dispatch expression) block environment expression))
-
-(define global-block)
-
-(define (environment/make)
- '())
-
-(define (environment/lookup environment name)
- (let ((association (assq name environment)))
- (if association
- (cdr association)
- (block/lookup-name global-block name))))
-
-(define (environment/bind environment variables)
- (map* environment
- (lambda (variable)
- (cons (variable/name variable) variable))
- variables))
-\f
-(define (transform/open-block block environment expression)
- (open-block-components expression
- (transform/open-block* (block/make block true) environment)))
-
-(define ((transform/open-block* block environment) auxiliary declarations body)
- (let ((variables (map (lambda (name) (variable/make block name)) auxiliary)))
- (block/set-bound-variables! block
- (append (block/bound-variables block)
- variables))
- (block/set-declarations! block (declarations/parse block declarations))
- (let ((environment (environment/bind environment variables)))
-
- (define (loop variables actions)
- (cond ((null? variables)
- (return-2 '() (map transform actions)))
- ((null? actions)
- (error "Extraneous auxiliaries" variables))
-
- ;; Because `scan-defines' returns the auxiliary names in a
- ;; particular order, we can expect to encounter them in that
- ;; same order when looking through the body's actions.
-
- ((and (scode-assignment? (car actions))
- (eq? (assignment-name (car actions))
- (variable/name (car variables))))
- (transmit-values (loop (cdr variables) (cdr actions))
- (lambda (values actions*)
- (return-2
- (cons (transform (assignment-value (car actions))) values)
- (cons open-block/value-marker actions*)))))
- (else
- (transmit-values (loop variables (cdr actions))
- (lambda (values actions*)
- (return-2 values
- (cons (transform (car actions)) actions*)))))))
-
- (define (transform subexpression)
- (transform/expression block environment subexpression))
-
- (transmit-values (loop variables (sequence-actions body))
- (lambda (values actions)
- (open-block/make block variables values actions))))))
-
-(define (transform/variable block environment expression)
- (reference/make block
- (environment/lookup environment (variable-name expression))))
-
-(define (transform/assignment block environment expression)
- (assignment-components expression
- (lambda (name value)
- (assignment/make block
- (environment/lookup environment name)
- (transform/expression block environment value)))))
-\f
-(define (transform/lambda block environment expression)
- (lambda-components* expression
- (lambda (name required optional rest body)
- (let ((block (block/make block true)))
- (transmit-values
- (let ((name->variable (lambda (name) (variable/make block name))))
- (return-3 (map name->variable required)
- (map name->variable optional)
- (and rest (name->variable rest))))
- (lambda (required optional rest)
- (let ((bound `(,@required ,@optional ,@(if rest `(,rest) '()))))
- (block/set-bound-variables! block bound)
- (procedure/make
- block name required optional rest
- (transform/procedure-body block
- (environment/bind environment bound)
- body)))))))))
-
-(define (transform/procedure-body block environment expression)
- (if (scode-open-block? expression)
- (open-block-components expression
- (lambda (auxiliary declarations body)
- (if (null? auxiliary)
- (begin (block/set-declarations!
- block
- (declarations/parse block declarations))
- (transform/expression block environment body))
- (transform/open-block block environment expression))))
- (transform/expression block environment expression)))
-
-(define (transform/definition block environment expression)
- (definition-components expression
- (lambda (name value)
- (error "Unscanned definition encountered. Unable to proceed." name))))
-
-(define (transform/access block environment expression)
- (access-components expression
- (lambda (environment* name)
- (access/make (transform/expression block environment environment*)
- name))))
-
-(define (transform/combination block environment expression)
- (combination-components expression
- (lambda (operator operands)
- (combination/make (transform/expression block environment operator)
- (transform/expressions block environment operands)))))
-
-(define (transform/comment block environment expression)
- (transform/expression block (comment-expression environment expression)))
-\f
-(define (transform/conditional block environment expression)
- (conditional-components expression
- (lambda (predicate consequent alternative)
- (conditional/make
- (transform/expression block environment predicate)
- (transform/expression block environment consequent)
- (transform/expression block environment alternative)))))
-
-(define (transform/constant block environment expression)
- (constant/make expression))
-
-(define (transform/declaration block environment expression)
- (declaration-components expression
- (lambda (declarations expression)
- (declaration/make (declarations/parse block declarations)
- (transform/expression block environment expression)))))
-
-(define (transform/delay block environment expression)
- (delay/make
- (transform/expression block environment (delay-expression expression))))
-
-(define (transform/disjunction block environment expression)
- (disjunction-components expression
- (lambda (predicate alternative)
- (disjunction/make
- (transform/expression block environment predicate)
- (transform/expression block environment alternative)))))
-
-(define (transform/in-package block environment expression)
- (in-package-components expression
- (lambda (environment* expression)
- (in-package/make (transform/expression block environment environment*)
- (transform/quotation* expression)))))
-
-(define (transform/quotation block environment expression)
- (transform/quotation* (quotation-expression expression)))
-
-(define (transform/quotation* expression)
- (transmit-values (transform/top-level expression)
- quotation/make))
-
-(define (transform/sequence block environment expression)
- (sequence/make
- (transform/expressions block environment (sequence-actions expression))))
-
-(define (transform/the-environment block environment expression)
- (block/unsafe! block)
- (the-environment/make block))
-\f
-(define transform/dispatch
- (make-type-dispatcher
- `((,access-type ,transform/access)
- (,assignment-type ,transform/assignment)
- (,combination-type ,transform/combination)
- (,comment-type ,transform/comment)
- (,conditional-type ,transform/conditional)
- (,declaration-type ,transform/declaration)
- (,definition-type ,transform/definition)
- (,delay-type ,transform/delay)
- (,disjunction-type ,transform/disjunction)
- (,in-package-type ,transform/in-package)
- (,lambda-type ,transform/lambda)
- (,open-block-type ,transform/open-block)
- (,quotation-type ,transform/quotation)
- (,sequence-type ,transform/sequence)
- (,the-environment-type ,transform/the-environment)
- (,variable-type ,transform/variable))
- transform/constant))
\ No newline at end of file
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $
- *
- * This File contains the code to translate internal format binary
- * files to portable format.
- *
- */
-\f
-/* Cheap renames */
-
-#define Internal_File Input_File
-#define Portable_File Output_File
-
-#include "translate.h"
-#include "trap.h"
-
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static long NFlonums, NIntegers, NStrings;
-static long NBits, NChars;
-static Pointer *Free_Objects, *Free_Cobjects;
-
-Load_Data(Count, To_Where)
-long Count;
-char *To_Where;
-{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
-}
-
-#define Reloc_or_Load_Debug false
-
-#include "load.c"
-\f
-/* Utility macros and procedures
- Pointer Objects handled specially in the portable format.
-*/
-
-#ifndef isalpha
-/* Just in case the stdio library atypically contains the character
- macros, just like the C book claims. */
-#include <ctype.h>
-#endif
-
-#ifndef ispunct
-/* This is in some libraries but not others */
-static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
-
-Boolean ispunct(c)
-fast char c;
-{ fast char *s = &punctuation[0];
- while (*s != '\0') if (*s++ == c) return true;
- return false;
-}
-#endif
-
-#define OUT(s) \
-fprintf(Portable_File, s); \
-break
-
-void
-print_a_char(c, name)
- fast char c;
- char *name;
-{
- switch(c)
- { case '\n': OUT("\\n");
- case '\t': OUT("\\t");
- case '\b': OUT("\\b");
- case '\r': OUT("\\r");
- case '\f': OUT("\\f");
- case '\\': OUT("\\\\");
- case '\0': OUT("\\0");
- case ' ' : OUT(" ");
- default:
- if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
- putc(c, Portable_File);
- else
- { fprintf(stderr,
- "%s: %s: File may not be portable: c = 0x%x\n",
- Program_Name, name, ((int) c));
- /* This does not follow C conventions, but eliminates ambiguity */
- fprintf(Portable_File, "\X%x ", ((int) c));
- }
- }
-}
-\f
-#define Do_String(Code, Rel, Fre, Scn, Obj, FObj) \
-{ \
- Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { \
- fast long i; \
- \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_CHARACTER_STRING, 0); \
- *(FObj)++ = Old_Contents; \
- i = Get_Integer(Old_Contents); \
- NStrings += 1; \
- NChars += pointer_to_char(i-1); \
- while(--i >= 0) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
-
-void
-print_a_string(from)
- Pointer *from;
-{ fast long len;
- fast char *string;
- long maxlen;
-
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
- if (Shuffle_Bytes)
- { while(len > 0)
- {
- print_a_char(string[3], "print_a_string");
- if (len > 1)
- print_a_char(string[2], "print_a_string");
- if (len > 2)
- print_a_char(string[1], "print_a_string");
- if (len > 3)
- print_a_char(string[0], "print_a_string");
- len -= 4;
- string += 4;
- }
- }
- else while(--len >= 0) print_a_char(*string++, "print_a_string");
- putc('\n', Portable_File);
- return;
-}
-\f
-void
-print_a_fixnum(val)
- long val;
-{
- fast long size_in_bits;
- fast unsigned long temp;
-
- temp = ((val < 0) ? -val : val);
- for (size_in_bits = 0; temp != 0; size_in_bits += 1)
- temp = temp >> 1;
- fprintf(Portable_File, "%02x %c ",
- TC_FIXNUM,
- (val < 0 ? '-' : '+'));
- if (val == 0)
- fprintf(Portable_File, "0\n");
- else
- {
- fprintf(Portable_File, "%ld ", size_in_bits);
- temp = ((val < 0) ? -val : val);
- while (temp != 0)
- { fprintf(Portable_File, "%01lx", (temp % 16));
- temp = temp >> 4;
- }
- fprintf(Portable_File, "\n");
- }
- return;
-}
-\f
-#define Do_Bignum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { fast long length; \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- NIntegers += 1; \
- NBits += bignum_to_bits(LEN(BIGNUM(Old_Address))); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FIXNUM, 0); \
- *(FObj)++ = Old_Contents; \
- for (length = Get_Integer(Old_Contents); \
- --length >= 0; ) \
- *(FObj)++ = *Old_Address++; \
- } \
-}
-
-void
-print_a_bignum(from)
- Pointer *from;
-{
- fast bigdigit *the_number, *the_top;
- fast long size_in_bits;
- fast unsigned long temp; /* Potential signed problems */
-
- the_number = BIGNUM(from);
- temp = LEN(the_number);
- if (temp == 0)
- fprintf(Portable_File, "%02x + 0\n",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
- else
- { fast long tail;
- for (size_in_bits = ((temp - 1) * SHIFT),
- temp = ((long) (*Bignum_Top(the_number)));
- temp != 0;
- size_in_bits += 1)
- temp = temp >> 1;
-
- fprintf(Portable_File, "%02x %c %ld ",
- (Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
- (NEG_BIGNUM(the_number) ? '-' : '+'),
- size_in_bits);
- tail = size_in_bits % SHIFT;
- if (tail == 0) tail = SHIFT;
- temp = 0;
- size_in_bits = 0;
- the_top = Bignum_Top(the_number);
- for(the_number = Bignum_Bottom(the_number);
- the_number <= the_top;
- the_number += 1)
- { temp |= (((unsigned long) (*the_number)) << size_in_bits);
- for (size_in_bits += ((the_number != the_top) ? SHIFT : tail);
- size_in_bits > 3;
- size_in_bits -= 4)
- { fprintf(Portable_File, "%01lx", temp % 16);
- temp = temp >> 4;
- }
- }
- if (size_in_bits > 0) fprintf(Portable_File, "%01lx\n", temp);
- else fprintf(Portable_File, "\n");
- }
- return;
-}
-\f
-#define Do_Flonum(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Obj)); \
- Mem_Base[(Scn)] = Make_Non_Pointer((Code), (Obj)); \
- (Obj) += 1; \
- *(FObj)++ = Make_Non_Pointer(TC_BIG_FLONUM, 0); \
- *((double *) (FObj)) = *((double *) Old_Address); \
- (FObj) += float_to_pointer; \
- NFlonums += 1; \
- } \
-}
-
-print_a_flonum(val)
-double val;
-{ fast long size_in_bits;
- fast double mant, temp;
- int expt;
- extern double frexp();
-
- fprintf(Portable_File, "%02x %c ",
- TC_BIG_FLONUM,
- ((val < 0.0) ? '-' : '+'));
- if (val == 0.0)
- { fprintf(Portable_File, "0\n");
- return;
- }
- mant = frexp(((val < 0.0) ? -val : val), &expt);
- size_in_bits = 1;
- for(temp = ((mant * 2.0) - 1.0);
- temp != 0;
- size_in_bits += 1)
- { temp *= 2.0;
- if (temp >= 1.0) temp -= 1.0;
- }
- fprintf(Portable_File, "%ld %ld ", expt, size_in_bits);
- for (size_in_bits = hex_digits(size_in_bits);
- size_in_bits > 0;
- size_in_bits -= 1)
- { fast unsigned int digit = 0;
- for (expt = 4; --expt >= 0;)
- { mant *= 2.0;
- digit = digit << 1;
- if (mant >= 1.0)
- { mant -= 1.0;
- digit += 1;
- }
- }
- fprintf(Portable_File, "%01x", digit);
- }
- fprintf(Portable_File, "\n");
- return;
-}
-\f
-/* Normal Objects */
-
-#define Do_Cell(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- } \
-}
-
-#define Do_Pair(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
-}
-
-#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- Mem_Base[(Fre)++] = *Old_Address++; \
- } \
-}
-
-#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
-{ Old_Address += (Rel); \
- Old_Contents = *Old_Address; \
- if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
- else \
- { fast long len = Get_Integer(Old_Contents); \
- *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
- Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
- Mem_Base[(Fre)++] = Old_Contents; \
- while (len > 0) \
- { Mem_Base[(Fre)++] = *Old_Address++; \
- len -= 1; \
- } \
- } \
-}
-\f
-/* Common Pointer Code */
-
-#define Do_Pointer(Scn, Action) \
-Old_Address = Get_Pointer(This); \
-if (Datum(This) < Const_Base) \
- Action(HEAP_CODE, Heap_Relocation, Free, \
- Scn, Objects, Free_Objects) \
-else if (Datum(This) < Dumped_Constant_Top) \
-Action(CONSTANT_CODE, Constant_Relocation, Free_Constant, \
- Scn, Constant_Objects, Free_Cobjects) \
-else \
-{ fprintf(stderr, \
- "%s: File is not portable: Pointer to stack.\n", \
- Program_Name); \
- exit(1); \
-} \
-(Scn) += 1; \
-break
-\f
-/* Processing of a single area */
-
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area(Code, &Area, &Bound, &Obj, &FObj)
-
-Process_Area(Code, Area, Bound, Obj, FObj)
-int Code;
-fast long *Area, *Bound;
-fast long *Obj;
-fast Pointer **FObj;
-{ fast Pointer This, *Old_Address, Old_Contents;
- while(*Area != *Bound)
- { This = Mem_Base[*Area];
- Switch_by_GC_Type(This)
- { case TC_MANIFEST_NM_VECTOR:
- if (Null_NMV)
- { fast int i = Get_Integer(This);
- *Area += 1;
- for ( ; --i >= 0; *Area += 1)
- Mem_Base[*Area] = NIL;
- break;
- }
- /* else, Unknown object! */
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *Area += 1 + Get_Integer(This);
- break;
-
- case TC_BROKEN_HEART:
- /* [Broken Heart 0] is the cdr of fasdumped symbols. */
- if (Get_Integer(This) != 0)
- { fprintf(stderr, "%s: Broken Heart found in scan.\n",
- Program_Name);
- exit(1);
- }
- *Area += 1;
- break;
-
- case_compiled_entry_point:
- fprintf(stderr,
- "%s: File is not portable: Compiled code.\n",
- Program_Name);
- exit(1);
-\f
- case TC_FIXNUM:
- NIntegers += 1;
- NBits += fixnum_to_bits;
- /* Fall Through */
- case TC_CHARACTER:
- Process_Character:
- Mem_Base[*Area] = Make_Non_Pointer(Code, *Obj);
- *Obj += 1;
- **FObj = This;
- *FObj += 1;
- /* Fall through */
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case TC_PRIMITIVE_EXTERNAL:
- case_simple_Non_Pointer:
- *Area += 1;
- break;
-
- case_Cell:
- Do_Pointer(*Area, Do_Cell);
-
- case TC_REFERENCE_TRAP:
- {
- long kind;
-
- kind = Datum(This);
-
- if (upgrade_traps)
- {
- /* It is an old UNASSIGNED object. */
- if (kind == 0)
- {
- Mem_Base[*Area] = UNASSIGNED_OBJECT;
- *Area += 1;
- break;
- }
- if (kind == 1)
- {
- Mem_Base[*Area] = UNBOUND_OBJECT;
- *Area += 1;
- break;
- }
- fprintf(stderr,
- "%s: Bad old unassigned object. 0x%x.\n",
- Program_Name, This);
- exit(1);
- }
- if (kind <= TRAP_MAX_IMMEDIATE)
- {
- /* It is a non pointer. */
-
- *Area += 1;
- break;
- }
- }
- /* Fall through */
-\f
- case TC_WEAK_CONS:
- case_Pair:
- Do_Pointer(*Area, Do_Pair);
-
- case TC_VARIABLE:
- case_Triple:
- Do_Pointer(*Area, Do_Triple);
-
- case TC_BIG_FLONUM:
- Do_Pointer(*Area, Do_Flonum);
-
- case TC_BIG_FIXNUM:
- Do_Pointer(*Area, Do_Bignum);
-
- case TC_CHARACTER_STRING:
- Do_Pointer(*Area, Do_String);
-
- case TC_ENVIRONMENT:
- if (upgrade_traps)
- {
- fprintf(stderr,
- "%s: Cannot upgrade environments.\n",
- Program_Name);
- exit(1);
- }
- /* Fall through */
- case TC_FUTURE:
- case_simple_Vector:
- Do_Pointer(*Area, Do_Vector);
-
- default:
- Bad_Type:
- fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
- Program_Name, Type_Code(This));
- exit(1);
- }
- }
-}
-\f
-/* Output macros */
-
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
-
-#define print_external_object(from) \
-{ switch(Type_Code(*from)) \
- { case TC_FIXNUM: \
- { long Value; \
- Sign_Extend(*from++, Value); \
- print_a_fixnum(Value); \
- break; \
- } \
- case TC_BIG_FIXNUM: \
- from += 1; \
- print_a_bignum(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_CHARACTER_STRING: \
- from += 1; \
- print_a_string(from); \
- from += 1 + Get_Integer(*from); \
- break; \
- case TC_BIG_FLONUM: \
- print_a_flonum(*((double *) (from+1))); \
- from += 1 + float_to_pointer; \
- break; \
- case TC_CHARACTER: \
- fprintf(Portable_File, "%02x %03x\n", \
- TC_CHARACTER, (*from & MASK_EXTNDD_CHAR)); \
- from += 1; \
- break; \
- default: \
- fprintf(stderr, \
- "%s: Bad Object to print externally %lx\n", \
- Program_Name, *from); \
- exit(1); \
- } \
-}
-\f
-/* Debugging Aids and Consistency Checks */
-
-#ifdef DEBUG
-
-When(what, message)
-Boolean what;
-char *message;
-{ if (what)
- { fprintf(stderr, "%s: Inconsistency: %s!\n",
- Program_Name, (message));
- exit(1);
- }
- return;
-}
-
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj)); \
-fprintf(stderr, "%s: ", (name)); \
-fprintf(stderr, (format), (obj))
-
-#else
-
-#define When(what, message)
-
-#define print_header(name, obj, format) \
-fprintf(Portable_File, (format), (obj))
-
-#endif
-\f
-/* The main program */
-
-do_it()
-{ Pointer *Heap;
- long Initial_Free;
-
- /* Load the Data */
-
- if (!Read_Header())
- { fprintf(stderr,
- "%s: Input file does not appear to be in FASL format.\n",
- Program_Name);
- exit(1);
- }
-
- if ((Version != FASL_FORMAT_VERSION) ||
- (Sub_Version > FASL_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUPPORTED) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
- { fprintf(stderr, "%s:\n", Program_Name);
- fprintf(stderr,
- "FASL File Version %ld Subversion %ld Machine Type %ld\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- "Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- exit(1);
- }
-
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- Shuffle_Bytes = false;
- upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
-
- /* Constant Space not currently supported */
-
- if (Const_Count != 0)
- { fprintf(stderr,
- "%s: Input file has a constant space area.\n",
- Program_Name);
- exit(1);
- }
-
- { long Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
- Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
- if (Heap == NULL)
- { fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
- exit(1);
- }
- }
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
- Load_Data(Heap_Count, &Heap[0]);
- Load_Data(Const_Count, &Heap[Heap_Count]);
- Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
- Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
- fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
- fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
- fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
- fprintf(stderr, "Constant Count = %6d\n", Const_Count);
-#endif
-\f
- /* Reformat the data */
-
- NFlonums = NIntegers = NStrings = NBits = NChars = 0;
- Mem_Base = &Heap[Heap_Count + Const_Count];
- if (Ext_Prim_Vector == NIL)
- { Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Mem_Base[2] = NIL;
- Initial_Free = NROOTS + 1;
- Scan = 1;
- }
- else
- { Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Initial_Free = NROOTS;
- Scan = 0;
- }
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
- Objects = 0;
-
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
- Constant_Objects = 0;
-
-#if true
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
-#else
- /* When Constant Space finally becomes supported,
- something like this must be done. */
- while (true)
- { Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant,
- Free_Constant, Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
- if (Scan == Free) break;
- }
-#endif
-\f
- /* Consistency checks */
-
- When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
- "Free_Objects overran Heap Object Space");
- When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
- "Free_Constant overran Constant Space");
- When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
- Const_Count),
- "Free_Cobjects overran Constant Object Space");
-\f
- /* Output the data */
-
- /* Header */
-
- print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
- print_header("Flags", Make_Flags(), "%ld\n");
- print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
- print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
- print_header("Heap Count", (Free - NROOTS), "%ld\n");
- print_header("Heap Base", NROOTS, "%ld\n");
- print_header("Heap Objects", Objects, "%ld\n");
-
- /* Currently Constant and Pure not supported, but the header is ready */
-
- print_header("Pure Count", 0, "%ld\n");
- print_header("Pure Base", Free_Constant, "%ld\n");
- print_header("Pure Objects", 0, "%ld\n");
- print_header("Constant Count", 0, "%ld\n");
- print_header("Constant Base", Free_Constant, "%ld\n");
- print_header("Constant Objects", 0, "%ld\n");
-
- print_header("Number of flonums", NFlonums, "%ld\n");
- print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of strings", NStrings, "%ld\n");
- print_header("Number of bits in integers", NBits, "%ld\n");
- print_header("Number of characters in strings", NChars, "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
-\f
- /* External Objects */
-
- /* Heap External Objects */
-
- Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
- for (; Objects > 0; Objects -= 1)
- print_external_object(Free_Objects);
-
-#if false
- /* Pure External Objects */
-
- Free_Cobjects = &Mem_Base[Pure_Objects_Start];
- for (; Pure_Objects > 0; Pure_Objects -= 1)
- print_external_object(Free_Cobjects);
-
- /* Constant External Objects */
-
- Free_Cobjects = &Mem_Base[Constant_Objects_Start];
- for (; Constant_Objects > 0; Constant_Objects -= 1)
- print_external_object(Free_Cobjects);
-
-#endif
-\f
- /* Pointer Objects */
-
- /* Heap Objects */
-
- Free_Cobjects = &Mem_Base[Free];
- for (Free_Objects = &Mem_Base[NROOTS];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-
-#if false
- /* Pure Objects */
-
- Free_Cobjects = &Mem_Base[Free_Pure];
- for (Free_Objects = &Mem_Base[Pure_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-
- /* Constant Objects */
-
- Free_Cobjects = &Mem_Base[Free_Constant];
- for (Free_Objects = &Mem_Base[Constant_Start];
- Free_Objects < Free_Cobjects;
- Free_Objects += 1)
- print_an_object(*Free_Objects);
-#endif
-
- return;
-}
-\f
-/* Top Level */
-
-static int Noptions = 3;
-
-static struct Option_Struct Options[] =
- {{"Do_Not_Compact", false, &Compact_P},
- {"Null_Out_NMVs", true, &Null_NMV},
- {"Swap_Bytes", true, &Shuffle_Bytes}};
-
-main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.24 1987/04/16 02:20:20 jinx Rel $
- *
- * Named constants used throughout the interpreter
- *
- */
-\f
-#if (CHAR_SIZE != 8)
-#define MAX_CHAR ((1<<CHAR_SIZE)-1)
-#else
-#define MAX_CHAR 0xFF
-#endif
-
-#define PI 3.1415926535
-#define STACK_FRAME_HEADER 1
-
-/* Precomputed typed pointers */
-#ifndef b32 /* Safe version */
-
-#define NIL Make_Non_Pointer(TC_NULL, 0)
-#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
-
-#else /* 32 bit word */
-#define NIL 0x00000000
-#define TRUTH 0x08000000
-#define FIXNUM_ZERO 0x1A000000
-#define BROKEN_HEART_ZERO 0x22000000
-#endif /* b32 */
-
-#define NOT_THERE -1 /* Command line parser */
-\f
-/* Assorted sizes used in various places */
-
-#ifdef MAXPATHLEN
-#define FILE_NAME_LENGTH MAXPATHLEN
-#else
-#define FILE_NAME_LENGTH 1024 /* Max. chars. in a file name */
-#endif
-
-#define OBARRAY_SIZE 3001 /* Interning hash table */
-
-#ifndef STACK_GUARD_SIZE
-#define STACK_GUARD_SIZE 4096 /* Cells between constant and
- stack before overflow
- occurs */
-#endif
-
-/* Some versions of stdio define this. */
-#ifndef _NFILE
-#define _NFILE 15
-#endif
-
-#define FILE_CHANNELS _NFILE
-
-#define MAX_LIST_PRINT 10
-
-#define ILLEGAL_PRIMITIVE -1
-
-/* Hashing algorithm for interning */
-
-#define MAX_HASH_CHARS 5
-#define LENGTH_MULTIPLIER 5
-#define SHIFT_AMOUNT 2
-
-/* Last immediate reference trap. */
-
-#define TRAP_MAX_IMMEDIATE 9
-
-/* For headers in pure / constant area */
-
-#define END_OF_BLOCK TC_FIXNUM
-#define CONSTANT_PART TC_TRUE
-#define PURE_PART TC_FALSE
-
-/* Primitive flow control codes: directs computation after
- * processing a primitive application.
- */
-#define PRIM_DONE -1
-#define PRIM_DO_EXPRESSION -2
-#define PRIM_APPLY -3
-#define PRIM_INTERRUPT -4
-#define PRIM_NO_TRAP_EVAL -5
-#define PRIM_NO_TRAP_APPLY -6
-#define PRIM_POP_RETURN -7
-\f
-/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
-
-#define INT_Stack_Overflow 1 /* Local interrupt */
-#define INT_Global_GC 2
-#define INT_GC 4 /* Local interrupt */
-#define INT_Global_1 8
-#define INT_Character 16 /* Local interrupt */
-#define INT_Global_2 32
-#define INT_Timer 64 /* Local interrupt */
-#define INT_Global_3 128
-#define INT_Global_Mask \
- (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
-#define Global_GC_Level 1
-#define Global_1_Level 3
-#define Global_2_Level 5
-#define Global_3_Level 7
-#define MAX_INTERRUPT_NUMBER 7
-
-#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
-
-/* Error case detection for precomputed constants */
-/* VMS preprocessor does not like line continuations in conditionals */
-
-#define Are_The_Constants_Incompatible \
-((TC_NULL != 0x00) || (TC_TRUE != 0x08) || \
- (TC_FIXNUM != 0x1A) || (TC_BROKEN_HEART != 0x22) || \
- (TC_CHARACTER_STRING != 0x1E))
-
-/* The values used above are in sdata.h and types.h,
- check for consistency if the check below fails. */
-
-#if Are_The_Constants_Incompatible
-#include "Error: const.h and types.h disagree"
-#endif
-
-/* These are the only entries in Registers[] needed by the microcode.
- All other entries are used only by the compiled code interface. */
-
-#define REGBLOCK_MEMTOP 0
-#define REGBLOCK_STACKGUARD 1
-#define REGBLOCK_VAL 2
-#define REGBLOCK_ENV 3
-#define REGBLOCK_TEMP 4
-#define REGBLOCK_EXPR 5
-#define REGBLOCK_RETURN 6
-#define REGBLOCK_MINIMUM_LENGTH 7
-\f
-/* Codes specifying how to start scheme at boot time. */
-
-#define BOOT_FASLOAD 0
-#define BOOT_LOAD_BAND 1
-#define BOOT_GET_WORK 2
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
-
- Contains information relating to the format of FASL files.
- Some information is contained in CONFIG.H.
-*/
-\f
-/* FASL Version */
-
-#define FASL_FILE_MARKER 0XFAFAFAFA
-
-/* The FASL file has a header which begins as follows: */
-
-#define FASL_HEADER_LENGTH 50 /* Scheme objects in header */
-#define FASL_OLD_LENGTH 8 /* Size of header earlier */
-#define FASL_Offset_Marker 0 /* Marker to indicate FASL format */
-#define FASL_Offset_Heap_Count 1 /* Count of objects in heap */
-#define FASL_Offset_Heap_Base 2 /* Address of heap when dumped */
-#define FASL_Offset_Dumped_Obj 3 /* Where dumped object was */
-#define FASL_Offset_Const_Count 4 /* Count of objects in const. area */
-#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
-#define FASL_Offset_Version 6 /* FASL format version info. */
-#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
-#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
-
-#define FASL_Offset_First_Free 9 /* Used to clear header */
-
-/* Version information encoding */
-
-#define MACHINE_TYPE_LENGTH (POINTER_LENGTH/2)
-#define MACHINE_TYPE_MASK ((1<<MACHINE_TYPE_LENGTH)-1)
-#define The_Machine_Type(P) ((P) & MACHINE_TYPE_MASK)
-#define SUB_VERSION_LENGTH (MACHINE_TYPE_LENGTH-TYPE_CODE_LENGTH)
-#define SUB_VERSION_MASK ((1<<SUB_VERSION_LENGTH)-1)
-#define The_Sub_Version(P) (((P) >> MACHINE_TYPE_LENGTH) & SUB_VERSION_MASK)
-#define The_Version(P) Type_Code(P)
-#define Make_Version(V, S, M) \
- Make_Non_Pointer((V), (((S) << MACHINE_TYPE_LENGTH) | (M)))
-
-#define WRITE_FLAG "w"
-#define OPEN_FLAG "r"
-\f
-/* "Memorable" FASL versions -- ones where we modified something
- and want to remain backwards compatible.
-*/
-
-/* Versions. */
-
-#define FASL_FORMAT_ADDED_STACK 1
-
-/* Subversions of highest numbered version. */
-
-#define FASL_LONG_HEADER 3
-#define FASL_DENSE_TYPES 4
-#define FASL_PADDED_STRINGS 5
-#define FASL_REFERENCE_TRAP 6
-
-/* Current parameters. */
-
-#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_REFERENCE_TRAP
-#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fixobj.h,v 9.24 1987/04/03 00:12:59 jinx Exp $
- *
- * Declarations of user offsets into the Fixed Objects Vector.
- * This should correspond to the file UTABMD.SCM
- */
-\f
-#define Non_Object 0x00 /* Used for unassigned variables */
-#define System_Interrupt_Vector 0x01 /* Handlers for interrups */
-#define System_Error_Vector 0x02 /* Handlers for errors */
-#define OBArray 0x03 /* Array for interning symbols */
-#define Types_Vector 0x04 /* Type number -> Name map */
-#define Returns_Vector 0x05 /* Return code -> Name map */
-#define Primitives_Vector 0x06 /* Primitive code -> Name map */
-#define Errors_Vector 0x07 /* Error code -> Name map */
-#define Identification_Vector 0x08 /* ID Vector index -> name map */
-#define GC_Daemon 0x0B /* Procedure to run after GC */
-#define Trap_Handler 0x0C /* Continue after disaster */
-#define Stepper_State 0x0E /* NOT IMPLEMENTED YET */
-#define Fixed_Objects_Slots 0x0F /* Names of these slots */
-#define External_Primitives 0x10 /* Names of external prims */
-#define State_Space_Tag 0x11 /* Tag for state spaces */
-#define State_Point_Tag 0x12 /* Tag for state points */
-#define Dummy_History 0x13 /* Empty history structure */
-#define Bignum_One 0x14 /* Cache for bignum one */
-#define System_Scheduler 0x15 /* Scheduler for touched futures */
-#define Termination_Vector 0x16 /* Names for terminations */
-#define Termination_Proc_Vector 0x17 /* Handlers for terminations */
-#define Me_Myself 0x18 /* The actual shared vector */
-/* The next slot is used only in multiprocessor mode */
-#define The_Work_Queue 0x19 /* Where work is stored */
-/* These two slots are only used if logging futures */
-#define Future_Logger 0x1A /* Routine to log touched futures */
-#define Touched_Futures 0x1B /* Vector of touched futures */
-#define Precious_Objects 0x1C /* Objects that should not be lost! */
-#define Error_Procedure 0x1D /* User invoked error handler */
-#define Unsnapped_Link 0x1E /* Handler for call to compiled code */
-#define Utilities_Vector 0x1F /* ??? */
-#define Compiler_Err_Procedure 0x20 /* ??? */
-#define Lost_Objects_Base 0x21 /* Free at the end of the "real" gc. */
-#define State_Space_Root 0x22 /* Root of state space */
-
-#define NFixed_Objects 0x23
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.22 1987/04/03 00:14:08 jinx Exp $
- *
- * This file contains the table which maps between Types and
- * GC Types.
- *
- */
-\f
- /*********************************/
- /* Mapping GC_Type to Type_Codes */
- /*********************************/
-
-int GC_Type_Map[MAX_SAFE_TYPE + 1] = {
- GC_Non_Pointer, /* TC_NULL,etc */
- GC_Pair, /* TC_LIST */
- GC_Non_Pointer, /* TC_CHARACTER */
- GC_Pair, /* TC_SCODE_QUOTE */
- GC_Triple, /* TC_PCOMB2 */
- GC_Pair, /* TC_UNINTERNED_SYMBOL */
- GC_Vector, /* TC_BIG_FLONUM */
- GC_Pair, /* TC_COMBINATION_1 */
- GC_Non_Pointer, /* TC_TRUE */
- GC_Pair, /* TC_EXTENDED_PROCEDURE */
- GC_Vector, /* TC_VECTOR */
- GC_Non_Pointer, /* TC_RETURN_CODE */
- GC_Triple, /* TC_COMBINATION_2 */
- GC_Pair, /* TC_COMPILED_PROCEDURE */
- GC_Vector, /* TC_BIG_FIXNUM */
- GC_Pair, /* TC_PROCEDURE */
- GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
- GC_Pair, /* TC_DELAY */
- GC_Vector, /* TC_ENVIRONMENT */
- GC_Pair, /* TC_DELAYED */
- GC_Triple, /* TC_EXTENDED_LAMBDA */
- GC_Pair, /* TC_COMMENT */
- GC_Vector, /* TC_NON_MARKED_VECTOR */
- GC_Pair, /* TC_LAMBDA */
- GC_Non_Pointer, /* TC_PRIMITIVE */
- GC_Pair, /* TC_SEQUENCE_2 */
- GC_Non_Pointer, /* TC_FIXNUM */
- GC_Pair, /* TC_PCOMB1 */
- GC_Vector, /* TC_CONTROL_POINT */
- GC_Pair, /* TC_INTERNED_SYMBOL */
- GC_Vector, /* TC_CHARACTER_STRING,TC_VECTOR_8B */
- GC_Pair, /* TC_ACCESS */
- GC_Undefined, /* 0x20 */
- GC_Pair, /* TC_DEFINITION */
- GC_Special, /* TC_BROKEN_HEART */
- GC_Pair, /* TC_ASSIGNMENT */
- GC_Triple, /* TC_HUNK3 */
- GC_Pair, /* TC_IN_PACKAGE */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Vector, /* TC_COMBINATION */
- GC_Special, /* TC_MANIFEST_NM_VECTOR */
- GC_Compiled, /* TC_COMPILED_EXPRESSION */
- GC_Pair, /* TC_LEXPR */
- GC_Vector, /* TC_PCOMB3 */
- GC_Special, /* TC_MANIFEST_SPECIAL_NM_VECTOR */
- GC_Triple, /* TC_VARIABLE */
- GC_Non_Pointer, /* TC_THE_ENVIRONMENT */
- GC_Vector, /* TC_FUTURE */
- GC_Vector, /* TC_VECTOR_1B,TC_BIT_STRING */
- GC_Non_Pointer, /* TC_PCOMB0 */
- GC_Vector, /* TC_VECTOR_16B */
- GC_Special, /* TC_REFERENCE_TRAP */
- GC_Triple, /* TC_SEQUENCE_3 */
- GC_Triple, /* TC_CONDITIONAL */
- GC_Pair, /* TC_DISJUNCTION */
- GC_Cell, /* TC_CELL */
- GC_Pair, /* TC_WEAK_CONS */
- GC_Quadruple, /* TC_QUAD */
- GC_Compiled, /* TC_RETURN_ADDRESS */
- GC_Pair, /* TC_COMPILER_LINK */
- GC_Non_Pointer, /* TC_STACK_ENVIRONMENT */
- GC_Pair, /* TC_COMPLEX */
- GC_Undefined, /* 0x3D */
- GC_Undefined, /* 0x3E */
- GC_Undefined, /* 0x3F */
- GC_Undefined, /* 0x40 */
- GC_Undefined, /* 0x41 */
- GC_Undefined, /* 0x42 */
- GC_Undefined, /* 0x43 */
- GC_Undefined, /* 0x44 */
- GC_Undefined, /* 0x45 */
- GC_Undefined, /* 0x46 */
- GC_Undefined, /* 0x47 */
- GC_Undefined, /* 0x48 */
- GC_Undefined, /* 0x49 */
- GC_Undefined, /* 0x4A */
- GC_Undefined, /* 0x4B */
- GC_Undefined, /* 0x4C */
- GC_Undefined, /* 0x4D */
- GC_Undefined, /* 0x4E */
- GC_Undefined, /* 0x4F */
- GC_Undefined, /* 0x50 */
- GC_Undefined, /* 0x51 */
- GC_Undefined, /* 0x52 */
- GC_Undefined, /* 0x53 */
- GC_Undefined, /* 0x54 */
-
-/* GC_Type_Map continues on next page */
-\f
-/* GC_Type_Map continued */
-
- GC_Undefined, /* 0x55 */
- GC_Undefined, /* 0x56 */
- GC_Undefined, /* 0x57 */
- GC_Undefined, /* 0x58 */
- GC_Undefined, /* 0x59 */
- GC_Undefined, /* 0x5A */
- GC_Undefined, /* 0x5B */
- GC_Undefined, /* 0x5C */
- GC_Undefined, /* 0x5D */
- GC_Undefined, /* 0x5E */
- GC_Undefined, /* 0x5F */
- GC_Undefined, /* 0x60 */
- GC_Undefined, /* 0x61 */
- GC_Undefined, /* 0x62 */
- GC_Undefined, /* 0x63 */
- GC_Undefined, /* 0x64 */
- GC_Undefined, /* 0x65 */
- GC_Undefined, /* 0x66 */
- GC_Undefined, /* 0x67 */
- GC_Undefined, /* 0x68 */
- GC_Undefined, /* 0x69 */
- GC_Undefined, /* 0x6A */
- GC_Undefined, /* 0x6B */
- GC_Undefined, /* 0x6C */
- GC_Undefined, /* 0x6D */
- GC_Undefined, /* 0x6E */
- GC_Undefined, /* 0x6F */
- GC_Undefined, /* 0x70 */
- GC_Undefined, /* 0x71 */
- GC_Undefined, /* 0x72 */
- GC_Undefined, /* 0x73 */
- GC_Undefined, /* 0x74 */
- GC_Undefined, /* 0x75 */
- GC_Undefined, /* 0x76 */
- GC_Undefined, /* 0x77 */
- GC_Undefined, /* 0x78 */
- GC_Undefined, /* 0x79 */
- GC_Undefined, /* 0x7A */
- GC_Undefined, /* 0x7B */
- GC_Undefined, /* 0x7C */
- GC_Undefined, /* 0x7D */
- GC_Undefined, /* 0x7E */
- GC_Undefined /* 0x7F */
- };
-
-#if (MAX_SAFE_TYPE != 0x7F)
-#include "gctype.c and scheme.h inconsistent -- GC_Type_Map"
-#endif
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $
- *
- * This file contains the heart of the Scheme Scode
- * interpreter
- *
- */
-
-#define In_Main_Interpreter true
-#include "scheme.h"
-#include "locks.h"
-#include "trap.h"
-#include "lookup.h"
-#include "zones.h"
-\f
-/* In order to make the interpreter tail recursive (i.e.
- * to avoid calling procedures and thus saving unnecessary
- * state information), the main body of the interpreter
- * is coded in a continuation passing style.
- *
- * Basically, this is done by dispatching on the type code
- * for an Scode item. At each dispatch, some processing
- * is done which may include setting the return address
- * register, saving the current continuation (return address
- * and current expression) and jumping to the start of
- * the interpreter.
- *
- * It may be helpful to think of this program as being what
- * you would get if you wrote the straightforward Scheme
- * interpreter and then converted it into continuation
- * passing style as follows. At every point where you would
- * call EVAL to handle a sub-form, you put a jump back to
- * Do_Expression. Now, if there was code after the call to
- * EVAL you first push a "return code" (using Save_Cont) on
- * the stack and move the code that used to be after the
- * call down into the part of this file after the tag
- * Pop_Return.
- *
- * Notice that because of the caller saves convention used
- * here, all of the registers which are of interest have
- * been SAVEd on the racks by the time interpretation arrives
- * at Do_Expression (the top of EVAL).
- *
- * For notes on error handling and interrupts, see the file
- * utils.c.
- *
- * This file is divided into two parts. The first
- * corresponds is called the EVAL dispatch, and is ordered
- * alphabetically by the SCode item handled. The second,
- * called the return dispatch, begins at Pop_Return and is
- * ordered alphabetically by return code name.
- */
-\f
-#define Interrupt(Masked_Code) \
-{ \
- Export_Registers(); \
- Setup_Interrupt(Masked_Code); \
- Import_Registers(); \
- goto Perform_Application; \
-}
-
-#define Immediate_GC(N) \
-{ \
- Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
-}
-
-#define Prepare_Eval_Repeat() \
-{ \
- Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
- Store_Return(RC_EVAL_ERROR); \
- Save_Cont(); \
- Pushed(); \
-}
-
-#define Eval_GC_Check(Amount) \
-if (GC_Check(Amount)) \
-{ \
- Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
-}
-
-#define Eval_Error(Err) \
-{ \
- Export_Registers(); \
- Do_Micro_Error(Err, false); \
- Import_Registers(); \
- goto Internal_Apply; \
-}
-
-#define Pop_Return_Error(Err) \
-{ \
- Export_Registers(); \
- Do_Micro_Error(Err, true); \
- Import_Registers(); \
- goto Internal_Apply; \
-}
-
-#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
-{ \
- Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Contents_of_Val); \
- Save_Cont(); \
-}
-\f
-#define Reduces_To(Expr) \
- { Store_Expression(Expr); \
- New_Reduction(Fetch_Expression(), Fetch_Env()); \
- goto Do_Expression; \
- }
-
-#define Reduces_To_Nth(N) \
- Reduces_To(Fast_Vector_Ref(Fetch_Expression(), (N)))
-
-#define Do_Nth_Then(Return_Code, N, Extra) \
- { Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
- New_Subproblem(Fetch_Expression(), Fetch_Env()); \
- Extra; \
- goto Do_Expression; \
- }
-
-#define Do_Another_Then(Return_Code, N) \
- { Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), (N))); \
- Reuse_Subproblem(Fetch_Expression(), Fetch_Env()); \
- goto Do_Expression; \
- }
-
-#define Environment_P(Obj) (Obj == NIL || (Type_Code(Obj) == TC_ENVIRONMENT))
-
-#define MAGIC_RESERVE_SIZE 6 /* See SPMD.SCM */
-#define Reserve_Stack_Space() Will_Eventually_Push(MAGIC_RESERVE_SIZE)
-\f
- /***********************/
- /* Macros for Stepping */
- /***********************/
-
-#define Fetch_Trapper(field) \
- Vector_Ref(Get_Fixed_Obj_Slot(Stepper_State), (field))
-
-#define Fetch_Eval_Trapper() Fetch_Trapper(HUNK_CXR0)
-#define Fetch_Apply_Trapper() Fetch_Trapper(HUNK_CXR1)
-#define Fetch_Return_Trapper() Fetch_Trapper(HUNK_CXR2)
-\f
-/* Macros for handling FUTUREs */
-
-#ifdef COMPILE_FUTURES
-
-/* Arg_Type_Error handles the error returns from primitives which type check
- their arguments and restarts them or suspends if the argument is a future. */
-
-#define Arg_Type_Error(Arg_No, Err_No) \
-{ \
- fast Pointer *Arg, Orig_Arg; \
- \
- Arg = &(Stack_Ref(Arg_No-1)); \
- Orig_Arg = *Arg; \
- \
- if (Type_Code(*Arg) != TC_FUTURE) \
- Pop_Return_Error(Err_No); \
- \
- while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
- { \
- if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
- *Arg = Future_Value(*Arg); \
- } \
- if (Type_Code(*Arg) != TC_FUTURE) \
- goto Prim_No_Trap_Apply; \
- \
- Save_Cont(); \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
- Push(*Arg); /* Arg 1: The future itself */ \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- *Arg = Orig_Arg; \
- goto Apply_Non_Trapping; \
-}
-\f
-/* Apply_Future_Check is called at apply time to guarantee that certain
- objects (the procedure itself, and its LAMBDA components for user defined
- procedures) are not futures
-*/
-
-#define Apply_Future_Check(Name, Object) \
-{ \
- fast Pointer *Arg, Orig_Answer; \
- \
- Arg = &(Object); \
- Orig_Answer = *Arg; \
- \
- while (Type_Code(*Arg) == TC_FUTURE) \
- { \
- if (Future_Has_Value(*Arg)) \
- { \
- if (Future_Is_Keep_Slot(*Arg)) \
- Log_Touch_Of_Future(*Arg); \
- *Arg = Future_Value(*Arg); \
- } \
- else \
- { \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Store_Return(RC_INTERNAL_APPLY); \
- Val = NIL; \
- Save_Cont(); \
- Push(*Arg); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- *Arg = Orig_Answer; \
- goto Internal_Apply; \
- } \
- } \
- Name = *Arg; \
-}
-
-/* Future handling macros continue on the next page */
-\f
-/* Future handling macros, continued */
-
-/* Pop_Return_Val_Check suspends the process if the value calculated by
- a recursive call to EVAL is an undetermined future */
-
-#define Pop_Return_Val_Check() \
-{ \
- fast Pointer Orig_Val = Val; \
- \
- while (Type_Code(Val) == TC_FUTURE) \
- { \
- if (Future_Has_Value(Val)) \
- { \
- if (Future_Is_Keep_Slot(Val)) \
- Log_Touch_Of_Future(Val); \
- Val = Future_Value(Val); \
- } \
- else \
- { \
- Save_Cont(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Orig_Val); \
- Save_Cont(); \
- Push(Val); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- goto Internal_Apply; \
- } \
- } \
-}
-
-#else /* Not compiling FUTURES code */
-
-#define Pop_Return_Val_Check()
-#define Apply_Future_Check(Name, Object) Name = (Object)
-#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
-
-#endif
-\f
-/* The EVAL/APPLY ying/yang */
-
-void
-Interpret(dumped_p)
- Boolean dumped_p;
-{
- long Which_Way;
- fast Pointer *Reg_Block, *Reg_Stack_Pointer, *Reg_History;
-
- extern long enter_compiled_expression();
- extern long apply_compiled_procedure();
- extern long return_to_compiled_code();
-
- Reg_Block = &Registers[0];
-
- /* Primitives jump back here for errors, requests to
- * evaluate an expression, apply a function, or handle an
- * interrupt request. On errors or interrupts they leave
- * their arguments on the stack, the primitive itself in
- * Expression, and a RESTART_PRIMITIVE continuation in the
- * return register. In the other cases, they have removed
- * their stack frames entirely.
- */
-
- Which_Way = setjmp(*Back_To_Eval);
- Set_Time_Zone(Zone_Working);
- Import_Registers();
- if (Must_Report_References())
- { Save_Cont();
- Will_Push(CONTINUATION_SIZE + 2);
- Push(Val);
- Save_Env();
- Store_Return(RC_REPEAT_DISPATCH);
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
- Save_Cont();
- Pushed();
- Call_Future_Logging();
- }
-\f
-Repeat_Dispatch:
- switch (Which_Way)
- { case PRIM_APPLY: goto Internal_Apply;
- case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
- case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
- case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
- goto Eval_Non_Trapping;
- case 0: if (!dumped_p) break; /* Else fall through */
- case PRIM_POP_RETURN: goto Pop_Return;
- default: Pop_Return_Error(Which_Way);
- case PRIM_INTERRUPT:
- { Save_Cont();
- Interrupt(IntCode & IntEnb);
- }
- case ERR_ARG_1_WRONG_TYPE: Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
- case ERR_ARG_2_WRONG_TYPE: Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
- case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
- }
-\f
-Do_Expression:
-
- if (Eval_Debug)
- { Print_Expression(Fetch_Expression(), "Eval, expression");
- CRLF();
- }
-
-/* The expression register has an Scode item in it which
- * should be evaluated and the result left in Val.
- *
- * A "break" after the code for any operation indicates that
- * all processing for this operation has been completed, and
- * the next step will be to pop a return code off the stack
- * and proceed at Pop_Return. This is sometimes called
- * "executing the continuation" since the return code can be
- * considered the continuation to be performed after the
- * operation.
- *
- * An operation can terminate with a Reduces_To or
- * Reduces_To_Nth macro. This indicates that the value of
- * the current Scode item is the value returned when the
- * new expression is evaluated. Therefore no new
- * continuation is created and processing continues at
- * Do_Expression with the new expression in the expression
- * register.
- *
- * Finally, an operation can terminate with a Do_Nth_Then
- * macro. This indicates that another expression must be
- * evaluated and them some additional processing will be
- * performed before the value of this S-Code item available.
- * Thus a new continuation is created and placed on the
- * stack (using Save_Cont), the new expression is placed in
- * the Expression register, and processing continues at
- * Do_Expression.
- */
-\f
-/* Handling of Eval Trapping.
-
- If we are handling traps and there is an Eval Trap set,
- turn off all trapping and then go to Internal_Apply to call the
- user supplied eval hook with the expression to be evaluated and the
- environment.
-
-*/
-
- if (Microcode_Does_Stepping && Trapping && (Fetch_Eval_Trapper() != NIL))
- { Stop_Trapping();
- Will_Push(4);
- Push(Fetch_Env());
- Push(Fetch_Expression());
- Push(Fetch_Eval_Trapper());
- Push(STACK_FRAME_HEADER+2);
- Pushed();
- goto Apply_Non_Trapping;
- }
-\f
-Eval_Non_Trapping:
- Eval_Ucode_Hook();
- switch (Type_Code(Fetch_Expression()))
- { case TC_BIG_FIXNUM: /* The self evaluating items */
- case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- case TC_CHARACTER:
- case TC_COMPILED_PROCEDURE:
- case TC_COMPLEX:
- case TC_CONTROL_POINT:
- case TC_DELAYED:
- case TC_ENVIRONMENT:
- case TC_EXTENDED_PROCEDURE:
- case TC_FIXNUM:
- case TC_HUNK3:
- case TC_INTERNED_SYMBOL:
- case TC_LIST:
- case TC_NON_MARKED_VECTOR:
- case TC_NULL:
- case TC_PRIMITIVE:
- case TC_PRIMITIVE_EXTERNAL:
- case TC_PROCEDURE:
- case TC_QUAD:
- case TC_UNINTERNED_SYMBOL:
- case TC_TRUE:
- case TC_VECTOR:
- case TC_VECTOR_16B:
- case TC_VECTOR_1B:
- case TC_REFERENCE_TRAP:
- Val = Fetch_Expression(); break;
-
- case TC_ACCESS:
- Will_Push(CONTINUATION_SIZE);
- Do_Nth_Then(RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT, Pushed());
-
- case TC_ASSIGNMENT:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE, Pushed());
-
- case TC_BROKEN_HEART:
- Export_Registers();
- Microcode_Termination(TERM_BROKEN_HEART);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_COMBINATION:
- { long Array_Length = Vector_Length(Fetch_Expression())-1;
- Eval_GC_Check(New_Stacklet_Size(Array_Length+1+1+CONTINUATION_SIZE));
- Will_Push(Array_Length + 1+1+CONTINUATION_SIZE); /* Save_Env, Finger */
- Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Array_Length));
- /* The finger: last argument number */
- Pushed();
- if (Array_Length == 0)
- { Push(STACK_FRAME_HEADER); /* Frame size */
- Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
- }
- Save_Env();
- Do_Nth_Then(RC_COMB_SAVE_VALUE, Array_Length+1, {});
- }
-
- case TC_COMBINATION_1:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+2+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_COMB_1_PROCEDURE, COMB_1_ARG_1, {});
-
- case TC_COMBINATION_2:
- Reserve_Stack_Space(); /* STACK_ENV_EXTRA_SLOTS+3+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2, {});
-
- case TC_COMMENT:
- Reduces_To_Nth(COMMENT_EXPRESSION);
-
- case TC_CONDITIONAL:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_CONDITIONAL_DECIDE, COND_PREDICATE, Pushed());
-
- case TC_COMPILED_EXPRESSION:
- execute_compiled_setup();
- Store_Expression( (Pointer) Get_Pointer( Fetch_Expression()));
- Export_Registers();
- Which_Way = enter_compiled_expression();
- goto return_from_compiled_code;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_DEFINITION:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE, Pushed());
-
- case TC_DELAY:
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_DELAYED, Free);
- Free[THUNK_ENVIRONMENT] = Fetch_Env();
- Free[THUNK_PROCEDURE] =
- Fast_Vector_Ref(Fetch_Expression(), DELAY_OBJECT);
- Free += 2;
- break;
-
- case TC_DISJUNCTION:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_DISJUNCTION_DECIDE, OR_PREDICATE, Pushed());
-
- case TC_EXTENDED_LAMBDA: /* Close the procedure */
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_EXTENDED_PROCEDURE, Free);
- Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
- Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
- Free += 2;
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#ifdef COMPILE_FUTURES
- case TC_FUTURE:
- if (Future_Has_Value(Fetch_Expression()))
- { Pointer Future = Fetch_Expression();
- if (Future_Is_Keep_Slot(Future)) Log_Touch_Of_Future(Future);
- Reduces_To_Nth(FUTURE_VALUE);
- }
- Prepare_Eval_Repeat();
- Will_Push(STACK_ENV_EXTRA_SLOTS+2);
- Push(Fetch_Expression()); /* Arg: FUTURE object */
- Push(Get_Fixed_Obj_Slot(System_Scheduler));
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Internal_Apply;
-#endif
-
- case TC_IN_PACKAGE:
- Will_Push(CONTINUATION_SIZE);
- Do_Nth_Then(RC_EXECUTE_IN_PACKAGE_CONTINUE,
- IN_PACKAGE_ENVIRONMENT, Pushed());
-
- case TC_LAMBDA: /* Close the procedure */
- case TC_LEXPR:
- /* Deliberately omitted: Eval_GC_Check(2); */
- Val = Make_Pointer(TC_PROCEDURE, Free);
- Free[PROCEDURE_LAMBDA_EXPR] = Fetch_Expression();
- Free[PROCEDURE_ENVIRONMENT] = Fetch_Env();
- Free += 2;
- break;
-
- case TC_MANIFEST_NM_VECTOR:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Eval_Error(ERR_EXECUTE_MANIFEST_VECTOR);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_PCOMB0:
- /* In case we back out */
- Reserve_Stack_Space(); /* CONTINUATION_SIZE */
- Finished_Eventual_Pushing(); /* of this primitive */
-
-Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
- N_Args_Primitive(Get_Integer(Fetch_Expression())));
- Pushed();
- Stop_Trapping();
- goto Apply_Non_Trapping;
- }
-Prim_No_Trap_Apply:
- {
- fast long primitive_code;
-
- primitive_code = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
- break;
- }
-\f
- case TC_PCOMB1:
- Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
- Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
-
- case TC_PCOMB2:
- Reserve_Stack_Space(); /* 2+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT, {});
-
- case TC_PCOMB3:
- Reserve_Stack_Space(); /* 3+CONTINUATION_SIZE */
- Save_Env();
- Do_Nth_Then(RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT, {});
-
- case TC_SCODE_QUOTE:
- Val = Fast_Vector_Ref(Fetch_Expression(), SCODE_QUOTE_OBJECT);
- break;
-
- case TC_SEQUENCE_2:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_SEQ_2_DO_2, SEQUENCE_1, Pushed());
-
- case TC_SEQUENCE_3:
- Will_Push(CONTINUATION_SIZE + 1);
- Save_Env();
- Do_Nth_Then(RC_SEQ_3_DO_2, SEQUENCE_1, Pushed());
-
- case TC_THE_ENVIRONMENT:
- Val = Fetch_Env(); break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_VARIABLE:
- {
- long temp;
-
-#ifndef No_In_Line_Lookup
-
- fast Pointer *cell;
-
- Set_Time_Zone(Zone_Lookup);
- cell = Get_Pointer(Fetch_Expression());
- lookup(cell, Fetch_Env(), cell, repeat_variable_lookup);
- Val = *cell;
- if (Type_Code(Val) != TC_REFERENCE_TRAP)
- {
- Set_Time_Zone(Zone_Working);
- goto Pop_Return;
- }
-
- get_trap_kind(temp, Val);
- switch(temp)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- cell = Get_Pointer(Fetch_Expression());
- temp =
- deep_lookup_end(deep_lookup(Fetch_Env(), cell[VARIABLE_SYMBOL], cell),
- cell);
- goto external_lookup_return;
-
- /* No need to recompile, pass the fake variable. */
- case TRAP_FLUID:
- temp = deep_lookup_end(lookup_fluid(Val), fake_variable_object);
-
- external_lookup_return:
- Import_Val();
- if (temp != PRIM_DONE)
- break;
- Set_Time_Zone(Zone_Working);
- goto Pop_Return;
-
- case TRAP_UNBOUND:
- temp = ERR_UNBOUND_VARIABLE;
- break;
-
- case TRAP_UNASSIGNED:
- temp = ERR_UNASSIGNED_VARIABLE;
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- default:
- temp = ERR_BROKEN_COMPILED_VARIABLE;
- break;
- }
-
-#else No_In_Line_Lookup
-
- Set_Time_Zone(Zone_Lookup);
- temp = Lex_Ref(Fetch_Env(), Fetch_Expression());
- Import_Val();
- if (temp == PRIM_DONE)
- break;
-
-#endif No_In_Line_Lookup
-
- /* Back out of the evaluation. */
-
- Set_Time_Zone(Zone_Working);
-
- if (temp == PRIM_INTERRUPT)
- {
- Prepare_Eval_Repeat();
- Interrupt(IntCode & IntEnb);
- }
-
- Eval_Error(temp);
- }
-
- case TC_RETURN_CODE:
- default: Eval_Error(ERR_UNDEFINED_USER_TYPE);
- };
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-/* Now restore the continuation saved during an earlier part
- * of the EVAL cycle and continue as directed.
- */
-
-Pop_Return:
- Pop_Return_Ucode_Hook();
- Restore_Cont();
- if (Consistency_Check &&
- (Type_Code(Fetch_Return()) != TC_RETURN_CODE))
- { Push(Val); /* For possible stack trace */
- Save_Cont();
- Export_Registers();
- Microcode_Termination(TERM_BAD_STACK);
- }
- if (Eval_Debug)
- { Print_Return("Pop_Return, return code");
- Print_Expression(Val, "Pop_Return, value");
- CRLF();
- };
-
- /* Dispatch on the return code. A BREAK here will cause
- * a "goto Pop_Return" to occur, since this is the most
- * common occurrence.
- */
-
- switch (Get_Integer(Fetch_Return()))
- { case RC_COMB_1_PROCEDURE:
- Restore_Env();
- Push(Val); /* Arg. 1 */
- Push(NIL); /* Operator */
- Push(STACK_FRAME_HEADER+1);
- Finished_Eventual_Pushing();
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
-
- case RC_COMB_2_FIRST_OPERAND:
- Restore_Env();
- Push(Val);
- Save_Env();
- Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_COMB_2_PROCEDURE:
- Restore_Env();
- Push(Val); /* Arg 1, just calculated */
- Push(NIL); /* Function */
- Push(STACK_FRAME_HEADER+2);
- Finished_Eventual_Pushing();
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
-
- case RC_COMB_APPLY_FUNCTION:
- End_Subproblem();
- Stack_Ref(STACK_ENV_FUNCTION) = Val;
- goto Internal_Apply;
-
- case RC_COMB_SAVE_VALUE:
- { long Arg_Number;
-
- Restore_Env();
- Arg_Number = Get_Integer(Stack_Ref(STACK_COMB_FINGER))-1;
- Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
- Stack_Ref(STACK_COMB_FINGER) =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Arg_Number);
- /* DO NOT count on the type code being NMVector here, since
- the stack parser may create them with NIL here! */
- if (Arg_Number > 0)
- { Save_Env();
- Do_Another_Then(RC_COMB_SAVE_VALUE,
- (COMB_ARG_1_SLOT - 1) + Arg_Number);
- }
- Push(Fast_Vector_Ref(Fetch_Expression(), 0)); /* Frame Size */
- Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#define define_compiler_restart( return_code, entry) \
- case return_code: \
- { extern long entry(); \
- compiled_code_restart(); \
- Export_Registers(); \
- Which_Way = entry(); \
- goto return_from_compiled_code; \
- }
-
- define_compiler_restart( RC_COMP_INTERRUPT_RESTART,
- comp_interrupt_restart)
-
- define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART,
- comp_lexpr_interrupt_restart)
-
- define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART,
- comp_lookup_apply_restart)
-
- define_compiler_restart( RC_COMP_REFERENCE_RESTART,
- comp_reference_restart)
-
- define_compiler_restart( RC_COMP_ACCESS_RESTART,
- comp_access_restart)
-
- define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART,
- comp_unassigned_p_restart)
-
- define_compiler_restart( RC_COMP_UNBOUND_P_RESTART,
- comp_unbound_p_restart)
-
- define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART,
- comp_assignment_restart)
-
- define_compiler_restart( RC_COMP_DEFINITION_RESTART,
- comp_definition_restart)
-
- case RC_REENTER_COMPILED_CODE:
- compiled_code_restart();
- Export_Registers();
- Which_Way = return_to_compiled_code();
- goto return_from_compiled_code;
-\f
- case RC_CONDITIONAL_DECIDE:
- Pop_Return_Val_Check();
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth((Val==NIL)? COND_ALTERNATIVE : COND_CONSEQUENT);
-
- case RC_DISJUNCTION_DECIDE:
- /* Return predicate if it isn't NIL; else do ALTERNATIVE */
- Pop_Return_Val_Check();
- End_Subproblem();
- Restore_Env();
- if (Val != NIL) goto Pop_Return;
- Reduces_To_Nth(OR_ALTERNATIVE);
-
- case RC_END_OF_COMPUTATION:
- /* Signals bottom of stack */
- Export_Registers();
- Microcode_Termination(TERM_END_OF_COMPUTATION);
-
- case RC_EVAL_ERROR:
- /* Should be called RC_REDO_EVALUATION. */
- Store_Env(Pop());
- Reduces_To(Fetch_Expression());
-
- case RC_EXECUTE_ACCESS_FINISH:
- {
- long Result;
- Pointer value;
-
- Pop_Return_Val_Check();
- value = Val;
-
- if (Environment_P(Val))
- { Result = Symbol_Lex_Ref(value,
- Fast_Vector_Ref(Fetch_Expression(),
- ACCESS_NAME));
- Import_Val();
- if (Result == PRIM_DONE)
- {
- End_Subproblem();
- break;
- }
- if (Result != PRIM_INTERRUPT)
- {
- Val = value;
- Pop_Return_Error(Result);
- }
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
- Interrupt(IntCode & IntEnb);
- }
- Val = value;
- Pop_Return_Error(ERR_BAD_FRAME);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_EXECUTE_ASSIGNMENT_FINISH:
- {
- long temp;
- Pointer value;
- Lock_Handle set_serializer;
-
-#ifndef No_In_Line_Lookup
-
- Pointer bogus_unassigned;
- fast Pointer *cell;
-
- Set_Time_Zone(Zone_Lookup);
- Restore_Env();
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- lookup(cell, Fetch_Env(), cell, repeat_assignment_lookup);
- setup_lock(set_serializer, cell);
-
- value = Val;
- bogus_unassigned = Get_Fixed_Obj_Slot(Non_Object);
- if (value == bogus_unassigned)
- value = UNASSIGNED_OBJECT;
-
- if (Type_Code(*cell) != TC_REFERENCE_TRAP)
- {
- Val = *cell;
-
- normal_assignment_done:
- *cell = value;
- remove_lock(set_serializer);
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- get_trap_kind(temp, *cell);
- switch(temp)
- {
- case TRAP_DANGEROUS:
- case TRAP_UNBOUND_DANGEROUS:
- case TRAP_UNASSIGNED_DANGEROUS:
- case TRAP_FLUID_DANGEROUS:
- remove_lock(set_serializer);
- cell = Get_Pointer(Vector_Ref(Fetch_Expression(), ASSIGN_NAME));
- temp =
- deep_assignment_end(deep_lookup(Fetch_Env(),
- cell[VARIABLE_SYMBOL],
- cell),
- cell,
- value,
- false);
- goto external_assignment_return;
-
- case TRAP_UNASSIGNED:
- Val = bogus_unassigned;
- goto normal_assignment_done;
-
- case TRAP_FLUID:
- /* No need to recompile, pass the fake variable. */
- remove_lock(set_serializer);
- temp = deep_assignment_end(lookup_fluid(*cell),
- fake_variable_object,
- value,
- false);
-
- external_assignment_return:
- Import_Val();
- if (temp != PRIM_DONE)
- break;
- Set_Time_Zone(Zone_Working);
- End_Subproblem();
- goto Pop_Return;
-
- case TRAP_UNBOUND:
- remove_lock(set_serializer);
- temp = ERR_UNBOUND_VARIABLE;
- break;
-
- default:
- remove_lock(set_serializer);
- temp = ERR_BROKEN_COMPILED_VARIABLE;
- break;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-#else
-
- Set_Time_Zone(Zone_Lookup);
- Restore_Env();
- temp = Lex_Set(Fetch_Env(),
- Vector_Ref(Fetch_Expression(), ASSIGN_NAME),
- value);
- Import_Val();
- if (temp == PRIM_DONE)
- { End_Subproblem();
- Set_Time_Zone(Zone_Working);
- break;
- }
-
-#endif
-
- Set_Time_Zone(Zone_Working);
- Save_Env();
- if (temp != PRIM_INTERRUPT)
- {
- Val = value;
- Pop_Return_Error(temp);
- }
-
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
- value);
- Interrupt(IntCode & IntEnb);
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_EXECUTE_DEFINITION_FINISH:
- {
- Pointer value;
- long result;
-
- value = Val;
- Restore_Env();
- Export_Registers();
- result = Local_Set(Fetch_Env(),
- Fast_Vector_Ref(Fetch_Expression(), DEFINE_NAME),
- Val);
- Import_Registers();
- if (result == PRIM_DONE)
- {
- End_Subproblem();
- break;
- }
- Save_Env();
- if (result == PRIM_INTERRUPT)
- {
- Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
- value);
- Interrupt(IntCode & IntEnb);
- }
- Val = value;
- Pop_Return_Error(result);
- }
-
- case RC_EXECUTE_IN_PACKAGE_CONTINUE:
- Pop_Return_Val_Check();
- if (Environment_P(Val))
- {
- End_Subproblem();
- Store_Env(Val);
- Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
- }
- Pop_Return_Error(ERR_BAD_FRAME);
-\f
-#ifdef COMPILE_FUTURES
- case RC_FINISH_GLOBAL_INT:
- Export_Registers();
- Val = Global_Int_Part_2(Fetch_Expression(), Val);
- Import_Registers_Except_Val();
- break;
-#endif
-
- case RC_GC_CHECK:
- if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
- {
- Export_Registers();
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
- break;
-
- case RC_HALT:
- Export_Registers();
- Microcode_Termination(TERM_TERM_HANDLER);
-\f
- case RC_INTERNAL_APPLY:
-
-Internal_Apply:
-
-/* Branch here to perform a function application.
-
- At this point the top of the stack contains an application frame
- which consists of the following elements (see sdata.h):
- - A header specifying the frame length.
- - A procedure.
- - The actual (evaluated) arguments.
-
- No registers (except the stack pointer) are meaning full at this point.
- Before interrupts or errors are processed, some registers are cleared
- to avoid holding onto garbage if a garbage collection occurs.
-*/
-
-#define Prepare_Apply_Interrupt() \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Save_Cont(); \
-}
-
-#define Apply_Error(N) \
-{ \
- Store_Return(RC_INTERNAL_APPLY); \
- Store_Expression(NIL); \
- Val = NIL; \
- Pop_Return_Error(N); \
-}
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {
- long Count;
-
- Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
- Top_Of_Stack() = Fetch_Apply_Trapper();
- Push(STACK_FRAME_HEADER+Count);
- Stop_Trapping();
- }
-
-Apply_Non_Trapping:
-
- if ((IntCode & IntEnb) != 0)
- {
- long Interrupts;
-
- Interrupts = (IntCode & IntEnb);
- Store_Expression(NIL);
- Val = NIL;
- Prepare_Apply_Interrupt();
- Interrupt(Interrupts);
- }
-
-Perform_Application:
-
- Apply_Ucode_Hook();
-
- {
- fast Pointer Function;
-
- Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
-
- switch(Type_Code(Function))
- {
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_PROCEDURE:
- {
- fast long nargs;
-
- nargs = Get_Integer(Pop());
- Function = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
-
- {
- fast Pointer formals;
-
- Apply_Future_Check(formals,
- Fast_Vector_Ref(Function, LAMBDA_FORMALS));
-
- if ((nargs != Vector_Length(formals)) &&
- ((Type_Code(Function) != TC_LEXPR) ||
- (nargs < Vector_Length(formals))))
- {
- Push(STACK_FRAME_HEADER + nargs - 1);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- }
-
- if (Eval_Debug)
- {
- Print_Expression(Make_Unsigned_Fixnum(nargs),
- "APPLY: Number of arguments");
- }
-
- if (GC_Check(nargs + 1))
- {
- Push(STACK_FRAME_HEADER + nargs - 1);
- Prepare_Apply_Interrupt();
- Immediate_GC(nargs + 1);
- }
-
- {
- fast Pointer *scan;
-
- scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, nargs);
- while(--nargs >= 0)
- *scan++ = Pop();
- Free = scan;
- Reduces_To(Fast_Vector_Ref(Function, LAMBDA_SCODE));
- }
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_CONTROL_POINT:
- {
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG)
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Val = Stack_Ref(STACK_ENV_FIRST_ARG);
- Our_Throw(false, Function);
- Apply_Stacklet_Backout();
- Our_Throw_Part_2();
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- /*
- After checking the number of arguments, remove the
- frame header since primitives do not expect it.
- */
-
- case TC_PRIMITIVE:
- {
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
- }
-
- case TC_PRIMITIVE_EXTERNAL:
- {
- fast long NArgs, Proc;
-
- Proc = Datum(Function);
- if (Proc > MAX_EXTERNAL_PRIMITIVE)
- {
- Apply_Error(ERR_UNDEFINED_PRIMITIVE);
- }
- NArgs = N_Args_External(Proc);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- (NArgs + (STACK_ENV_FIRST_ARG - 1)))
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
-
-Repeat_External_Primitive:
- /* Reinitialize Proc in case we "goto Repeat_External..." */
- Proc = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Val = Apply_External(Proc);
- Set_Time_Zone(Zone_Working);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_External(Proc));
-
- goto Pop_Return;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_EXTENDED_PROCEDURE:
- {
- Pointer lambda;
- long nargs, nparams, formals, params, auxes,
- rest_flag, size;
-
- fast long i;
- fast Pointer *scan;
-
- nargs = Get_Integer(Pop()) - STACK_FRAME_HEADER;
-
- if (Eval_Debug)
- {
- Print_Expression(Make_Unsigned_Fixnum(nargs+STACK_FRAME_HEADER),
- "APPLY: Number of arguments");
- }
-
- lambda = Fast_Vector_Ref(Function, PROCEDURE_LAMBDA_EXPR);
- Apply_Future_Check(Function,
- Fast_Vector_Ref(lambda, ELAMBDA_NAMES));
- nparams = Vector_Length(Function) - 1;
-
- Apply_Future_Check(Function, Get_Count_Elambda(lambda));
- formals = Elambda_Formals_Count(Function);
- params = Elambda_Opts_Count(Function) + formals;
- rest_flag = Elambda_Rest_Flag(Function);
- auxes = nparams - (params + rest_flag);
-
- if ((nargs < formals) || (!rest_flag && (nargs > params)))
- {
- Push(STACK_FRAME_HEADER + nargs);
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
-
- /* size includes the procedure slot, but not the header. */
- size = params + rest_flag + auxes + 1;
- if (GC_Check(size + 1 + ((nargs > params) ?
- (2 * (nargs - params)) :
- 0)))
- {
- Push(STACK_FRAME_HEADER + nargs);
- Prepare_Apply_Interrupt();
- Immediate_GC(size + 1 + ((nargs > params) ?
- (2 * (nargs - params)) :
- 0));
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- scan = Free;
- Store_Env(Make_Pointer(TC_ENVIRONMENT, scan));
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, size);
-
- if (nargs <= params)
- {
- for (i = (nargs + 1); --i >= 0; )
- *scan++ = Pop();
- for (i = (params - nargs); --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- if (rest_flag)
- *scan++ = NIL;
- for (i = auxes; --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- }
- else
- {
- /* rest_flag must be true. */
- Pointer list;
-
- list = Make_Pointer(TC_LIST, (scan + size));
- for (i = (params + 1); --i >= 0; )
- *scan++ = Pop();
- *scan++ = list;
- for (i = auxes; --i >= 0; )
- *scan++ = UNASSIGNED_OBJECT;
- /* Now scan == Get_Pointer(list) */
- for (i = (nargs - params); --i >= 0; )
- {
- *scan++ = Pop();
- *scan = Make_Pointer(TC_LIST, (scan + 1));
- scan += 1;
- }
- scan[-1] = NIL;
- }
-
- Free = scan;
- Reduces_To(Get_Body_Elambda(lambda));
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case TC_COMPILED_PROCEDURE:
- {
- apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
- Export_Registers();
- Which_Way = apply_compiled_procedure();
-
-return_from_compiled_code:
- Import_Registers();
- switch (Which_Way)
- {
- case PRIM_DONE:
- { compiled_code_done();
- goto Pop_Return;
- }
-
- case PRIM_APPLY:
- { compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS +
- Get_Integer( Stack_Ref( STACK_ENV_HEADER)));
- goto Internal_Apply;
- }
-
- case ERR_COMPILED_CODE_ERROR:
- { /* The compiled code is signalling a microcode error. */
- compiled_error_backout();
- /* The Save_Cont is done by Pop_Return_Error. */
- Pop_Return_Error( compiled_code_error_code);
- }
-
- case PRIM_INTERRUPT:
- { compiled_error_backout();
- Save_Cont();
- Interrupt( (IntCode & IntEnb));
- }
-\f
- case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- { apply_compiled_backout();
- Apply_Error( Which_Way);
- }
-
- case ERR_EXECUTE_MANIFEST_VECTOR:
- { /* This error code means that enter_compiled_expression
- was called in a system without compiler support.
- */
- execute_compiled_backout();
- Val = Make_Non_Pointer( TC_COMPILED_EXPRESSION,
- Fetch_Expression());
- Pop_Return_Error( Which_Way);
- }
-
- case ERR_INAPPLICABLE_OBJECT:
- { /* This error code means that apply_compiled_procedure
- was called in a system without compiler support.
- */
- apply_compiled_backout();
- Apply_Error( Which_Way);
- }
-
- case ERR_INAPPLICABLE_CONTINUATION:
- { /* This error code means that return_to_compiled_code
- or some other compiler continuation was called in a
- system without compiler support.
- */
- Store_Expression(NIL);
- Store_Return(RC_REENTER_COMPILED_CODE);
- Pop_Return_Error(Which_Way);
- }
-
- default: Microcode_Termination( TERM_COMPILER_DEATH);
- }
- }
-
- default:
- Apply_Error(ERR_INAPPLICABLE_OBJECT);
- } /* End of switch in RC_INTERNAL_APPLY */
- } /* End of RC_INTERNAL_APPLY case */
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_MOVE_TO_ADJACENT_POINT:
- /* Expression contains the space in which we are moving */
- { long From_Count = Get_Integer(Stack_Ref(TRANSLATE_FROM_DISTANCE));
- Pointer Thunk, New_Location;
- if (From_Count != 0)
- { Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
- Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
- New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
- Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
- if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
- Stack_Pointer = Simulate_Popping(4);
- else Save_Cont();
- }
- else
- { long To_Count = Get_Integer(Stack_Ref(TRANSLATE_TO_DISTANCE))-1;
- fast Pointer To_Location = Stack_Ref(TRANSLATE_TO_POINT);
- fast long i;
- for (i=0; i < To_Count; i++)
- To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
- Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
- New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
- if (To_Count==0)
- Stack_Pointer = Simulate_Popping(4);
- else Save_Cont();
- }
- if (Fetch_Expression() != NIL)
- Vector_Set(Fetch_Expression(), STATE_SPACE_NEAREST_POINT, New_Location);
- else Current_State_Point = New_Location;
- Will_Push(2);
- Push(Thunk);
- Push(STACK_FRAME_HEADER);
- Pushed();
- goto Internal_Apply;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_INVOKE_STACK_THREAD:
- /* Used for WITH_THREADED_STACK primitive */
- Will_Push(3);
- Push(Val); /* Value calculated by thunk */
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Internal_Apply;
-
- case RC_JOIN_STACKLETS:
- Our_Throw(true, Fetch_Expression());
- Join_Stacklet_Backout();
- Our_Throw_Part_2();
- break;
-
- case RC_NORMAL_GC_DONE:
- End_GC_Hook();
- if (GC_Check(GC_Space_Needed))
- { printf("\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
- printf("is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_EXIT);
- }
- GC_Space_Needed = 0;
- Val = Fetch_Expression();
- break;
-\f
- case RC_PCOMB1_APPLY:
- End_Subproblem();
- Push(Val); /* Argument value */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
- goto Primitive_Internal_Apply;
-
- case RC_PCOMB2_APPLY:
- End_Subproblem();
- Push(Val); /* Value of arg. 1 */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB2_FN_SLOT));
- goto Primitive_Internal_Apply;
-
- case RC_PCOMB2_DO_1:
- Restore_Env();
- Push(Val); /* Save value of arg. 2 */
- Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
-
- case RC_PCOMB3_APPLY:
- End_Subproblem();
- Push(Val); /* Save value of arg. 1 */
- Finished_Eventual_Pushing();
- Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB3_FN_SLOT));
- goto Primitive_Internal_Apply;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_PCOMB3_DO_1:
- { Pointer Temp;
- Temp = Pop(); /* Value of arg. 3 */
- Restore_Env();
- Push(Temp); /* Save arg. 3 again */
- Push(Val); /* Save arg. 2 */
- Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
- }
-
- case RC_PCOMB3_DO_2:
- Restore_Then_Save_Env();
- Push(Val); /* Save value of arg. 3 */
- Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
-
- case RC_POP_RETURN_ERROR:
- case RC_RESTORE_VALUE:
- Val = Fetch_Expression();
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_PURIFY_GC_1:
- { Pointer GC_Daemon_Proc, Result;
- Export_Registers();
- Result = Purify_Pass_2(Fetch_Expression());
- Import_Registers();
- if (Result == NIL)
- { /* The object does not fit in Constant space.
- There is no need to run the daemons, and we should let the runtime
- system know what happened.
- */
- Val = NIL;
- break;
- }
- GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc==NIL)
- { Val = TRUTH;
- break;
- }
- Store_Expression(NIL);
- Store_Return(RC_PURIFY_GC_2);
- Save_Cont();
- Will_Push(2);
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
- Pushed();
- goto Internal_Apply;
- }
-
- case RC_PURIFY_GC_2:
- Val = TRUTH;
- break;
-
- case RC_REPEAT_DISPATCH:
- Sign_Extend(Fetch_Expression(), Which_Way);
- Restore_Env();
- Val = Pop();
- Restore_Cont();
- goto Repeat_Dispatch;
-
- case RC_REPEAT_PRIMITIVE:
- if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
- goto Repeat_External_Primitive;
- else goto Primitive_Internal_Apply;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
-/* The following two return codes are both used to restore
- a saved history object. The difference is that the first
- does not copy the history object while the second does.
- In both cases, the Expression register contains the history
- object and the next item to be popped off the stack contains
- the offset back to the previous restore history return code.
-
- ASSUMPTION: History objects are never created using futures.
-*/
-
- case RC_RESTORE_DONT_COPY_HISTORY:
- { Pointer Stacklet;
- Prev_Restore_History_Offset = Get_Integer(Pop());
- Stacklet = Pop();
- History = Get_Pointer(Fetch_Expression());
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = NULL;
- else if (Stacklet == NIL)
- Prev_Restore_History_Stacklet = NULL;
- else
- Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
- break;
- }
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_RESTORE_HISTORY:
- { Pointer Stacklet;
- Export_Registers();
- if (! Restore_History(Fetch_Expression()))
- { Import_Registers();
- Save_Cont();
- Will_Push(CONTINUATION_SIZE);
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Pushed();
- Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
- }
- Import_Registers();
- Prev_Restore_History_Offset = Get_Integer(Pop());
- Stacklet = Pop();
- if (Prev_Restore_History_Offset == 0)
- Prev_Restore_History_Stacklet = NULL;
- else
- { if (Stacklet == NIL)
- { Prev_Restore_History_Stacklet = NULL;
- Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
- }
- else
- { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
- Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
- Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
- }
- }
- break;
- }
-
- case RC_RESTORE_FLUIDS:
- Fluid_Bindings = Fetch_Expression();
- New_Compiler_MemTop();
- break;
-
- case RC_RESTORE_INT_MASK:
- IntEnb = Get_Integer(Fetch_Expression());
- New_Compiler_MemTop();
- break;
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_RESTORE_TO_STATE_POINT:
- { Pointer Where_To_Go = Fetch_Expression();
- Will_Push(CONTINUATION_SIZE);
- /* Restore the contents of Val after moving to point */
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Pushed();
- Export_Registers();
- Translate_To_Point(Where_To_Go);
- break; /* We never get here.... */
- }
-
- case RC_RETURN_TRAP_POINT:
- Store_Return(Old_Return_Code);
- Will_Push(CONTINUATION_SIZE+3);
- Save_Cont();
- Return_Hook_Address = NULL;
- Stop_Trapping();
- Push(Val);
- Push(Fetch_Return_Trapper());
- Push(STACK_FRAME_HEADER+1);
- Pushed();
- goto Apply_Non_Trapping;
-
- case RC_SEQ_2_DO_2:
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth(SEQUENCE_2);
-
- case RC_SEQ_3_DO_2:
- Restore_Then_Save_Env();
- Do_Another_Then(RC_SEQ_3_DO_3, SEQUENCE_2);
-
- case RC_SEQ_3_DO_3:
- End_Subproblem();
- Restore_Env();
- Reduces_To_Nth(SEQUENCE_3);
-
-/* Interpret() continues on the next page */
-\f
-/* Interpret(), continued */
-
- case RC_SNAP_NEED_THUNK:
- Vector_Set(Fetch_Expression(), THUNK_SNAPPED, TRUTH);
- Vector_Set(Fetch_Expression(), THUNK_VALUE, Val);
- break;
-
- case RC_AFTER_MEMORY_UPDATE:
- case RC_BAD_INTERRUPT_CONTINUE:
- case RC_COMPLETE_GC_DONE:
- case RC_RESTARTABLE_EXIT:
- case RC_RESTART_EXECUTION:
- case RC_RESTORE_CONTINUATION:
- case RC_RESTORE_STEPPER:
- case RC_POP_FROM_COMPILED_CODE:
- Export_Registers();
- Microcode_Termination(TERM_UNIMPLEMENTED_CONTINUATION);
-
- default:
- Export_Registers();
- Microcode_Termination(TERM_NON_EXISTENT_CONTINUATION);
- };
- goto Pop_Return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */
-
-/* Macros and declarations for the variable lookup code. */
-
-extern Pointer
- *deep_lookup(),
- *lookup_fluid();
-
-extern long
- deep_lookup_end(),
- deep_assignment_end();
-
-extern Pointer
- unbound_trap_object[],
- uncompiled_trap_object[],
- illegal_trap_object[],
- fake_variable_object[];
-\f
-#define GC_allocate_test(N) GC_Check(N)
-
-#define AUX_LIST_TYPE TC_VECTOR
-
-#define AUX_CHUNK_SIZE 20
-#define AUX_LIST_COUNT ENV_EXTENSION_COUNT
-#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE
-#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
-
-/* Variable compilation types. */
-
-#define LOCAL_REF TC_NULL
-#define GLOBAL_REF TC_UNINTERNED_SYMBOL
-#define FORMAL_REF TC_CHARACTER
-#define AUX_REF TC_FIXNUM
-#define UNCOMPILED_REF TC_TRUE
-
-/* Common constants. */
-
-#ifndef b32
-#define UNCOMPILED_VARIABLE Make_Non_Pointer(UNCOMPILED_REF, 0)
-#else
-#define UNCOMPILED_VARIABLE 0x08000000
-#endif
-
-/* Macros for speedy variable reference. */
-
-#if (LOCAL_REF == 0)
-
-#define Lexical_Offset(Ind) ((long) (Ind))
-#define Make_Local_Offset(Ind) ((Pointer) (Ind))
-
-#else
-
-#define Lexical_Offset(Ind) Get_Integer(Ind)
-#define Make_Local_Offset(Ind) Make_Non_Pointer(LOCAL_REF, Ind)
-
-#endif
-\f
-/* The code below depends on the following. */
-
-/* Done as follows because of VMS. */
-
-#define lookup_inconsistency_p \
- ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
- (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
-
-#if (lookup_inconsistency_p)
-#include "error: lookup.h inconsistency detected."
-#endif
-
-#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
-
-#ifdef PARALLEL_PROCESSOR
-
-#define verify(type_code, variable, code, label) \
-{ \
- variable = code; \
- if (Type_Code(Fetch(hunk[VARIABLE_COMPILED_TYPE])) != \
- type_code) \
- goto label; \
-}
-
-#define verified_offset(variable, code) variable
-
-/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
- not matter, but might on a machine with address mapping.
- */
-
-#define setup_lock(handle, cell) handle = Lock_Cell(cell)
-#define remove_lock(handle) Unlock_Cell(handle)
-
-#else
-
-#define verify(type_code, variable, code, label)
-#define verified_offset(variable, code) code
-#define setup_lock(handle, cell)
-#define remove_lock(ignore)
-
-#endif
-\f
-/* Pointer *cell, env, *hunk; */
-
-#define lookup(cell, env, hunk, label) \
-{ \
- fast Pointer frame; \
- long offset; \
- \
-label: \
- \
- frame = Fetch(hunk[VARIABLE_COMPILED_TYPE]); \
- \
- switch (Type_Code(frame)) \
- { \
- case GLOBAL_REF: \
- /* frame is a pointer to the same symbol. */ \
- cell = Nth_Vector_Loc(frame, SYMBOL_GLOBAL_VALUE); \
- break; \
- \
- case LOCAL_REF: \
- cell = Nth_Vector_Loc(env, Lexical_Offset(frame)); \
- break; \
- \
- case FORMAL_REF: \
- lookup_formal(cell, env, hunk, label); \
- \
- case AUX_REF: \
- lookup_aux(cell, env, hunk, label); \
- \
- default: \
- /* Done here rather than in a separate case because of \
- peculiarities of the bobcat compiler. \
- */ \
- cell = ((Type_Code(frame) == UNCOMPILED_REF) ? \
- uncompiled_trap_object : \
- illegal_trap_object); \
- break; \
- } \
-}
-\f
-#define lookup_formal(cell, env, hunk, label) \
-{ \
- fast long depth; \
- \
- verify(FORMAL_REF, offset, get_offset(hunk), label); \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- cell = Nth_Vector_Loc(frame, \
- verified_offset(offset, get_offset(hunk))); \
- \
- break; \
-}
-
-#define lookup_aux(cell, env, hunk, label) \
-{ \
- fast long depth; \
- \
- verify(AUX_REF, offset, get_offset(hunk), label); \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (Type_Code(frame) != AUX_LIST_TYPE) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
- break; \
-}
-\f
-#define lookup_primitive_type_test() \
-{ \
- if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
- if (Type_Code(Arg2) != TC_INTERNED_SYMBOL) \
- Arg_2_Type(TC_UNINTERNED_SYMBOL); \
-}
-
-#define lookup_primitive_end(Result) \
-{ \
- if (Result == PRIM_DONE) \
- return Val; \
- if (Result == PRIM_INTERRUPT) \
- Primitive_Interrupt(); \
- Primitive_Error(Result); \
-}
-
-#define standard_lookup_primitive(action) \
-{ \
- long Result; \
- \
- lookup_primitive_type_test(); \
- Result = action; \
- lookup_primitive_end(Result); \
- /*NOTREACHED*/ \
-}
-
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $
- *
- * This file contains the portable fixnum multiplication procedure.
- * Returns NIL if the result does not fit in a fixnum.
- * Note: This has only been tried on machines with long = 32 bits.
- * This file is included in the appropriate os file if needed.
- */
-\f
-#define HALF_WORD_SIZE ((sizeof(long)*CHAR_SIZE)/2)
-#define HALF_WORD_MASK (1<<HALF_WORD_SIZE)-1
-#define MAX_MIDDLE (1<<((ADDRESS_LENGTH-1)-HALF_WORD_SIZE))
-#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
-#define ABS(x) (((x) < 0) ? -(x) : (x))
-
-Pointer
-Mul(Arg1, Arg2)
- long Arg1, Arg2;
-{
- long A, B, C;
- fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
- Boolean Sign;
-
- Sign_Extend(Arg1, A);
- Sign_Extend(Arg2, B);
- Sign = ((A < 0) == (B < 0));
- A = ABS(A);
- B = ABS(B);
- Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
- Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
- Lo_A = (A & HALF_WORD_MASK);
- Lo_B = (B & HALF_WORD_MASK);
- Lo_C = (Lo_A * Lo_B);
- if (Lo_C > FIXNUM_SIGN_BIT)
- return NIL;
- Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
- if (Middle_C >= MAX_MIDDLE)
- return NIL;
- if ((Hi_A > 0) && (Hi_B > 0))
- return NIL;
- C = Lo_C + (Middle_C << HALF_WORD_SIZE);
- if (Fixnum_Fits(C))
- {
- if (Sign || (C == 0))
- return Make_Unsigned_Fixnum(C);
- else
- return Make_Unsigned_Fixnum(MAX_FIXNUM - C);
- }
- return NIL;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */
-
-/* This file contains definitions pertaining to the C view of
- Scheme pointers: widths of fields, extraction macros, pre-computed
- extraction masks, etc. */
-\f
-/* The C type Pointer is defined at the end of CONFIG.H
- The definition of POINTER_LENGTH here assumes that Pointer is the same
- as unsigned long. If that ever changes, this definition must also.
- POINTER_LENGTH is defined this way to make it available to
- the preprocessor. */
-
-#define POINTER_LENGTH ULONG_SIZE
-#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
-#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-
-/* The danger bit is being phased out. It is currently used by stacklets
- and the history mechanism. The variable lookup code no longer uses it.
- */
-
-#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
-#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
-#define SAFE_TYPE_MASK MAX_SAFE_TYPE
-#define DANGER_BIT HIGH_BIT
-
-#ifndef b32 /* Safe versions */
-
-#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
-#define TYPE_CODE_MASK (~ADDRESS_MASK)
-#define HIGH_BIT (1 << (POINTER_LENGTH-1))
-/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
-#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
-#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
-#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
-#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
-
-#else /* 32 bit word versions */
-
-#define ADDRESS_LENGTH 24
-#define ADDRESS_MASK 0x00FFFFFF
-#define TYPE_CODE_MASK 0xFF000000
-#define HIGH_BIT 0x80000000
-#define FIXNUM_LENGTH 23
-#define FIXNUM_SIGN_BIT 0x00800000
-#define SIGN_MASK 0xFF800000
-#define SMALLEST_FIXNUM 0xFF800000
-#define BIGGEST_FIXNUM 0x007FFFFF
-
-#endif
-\f
-#ifndef UNSIGNED_SHIFT /* Safe version */
-#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE)
-#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK)
-#else /* Faster for logical shifts */
-#define pointer_type(P) ((P) >> ADDRESS_LENGTH)
-#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK)
-#endif
-
-#define pointer_datum(P) ((P) & ADDRESS_MASK)
-
-/* compatibility definitions */
-#define Type_Code(P) (pointer_type (P))
-#define Safe_Type_Code(P) (safe_pointer_type (P))
-#define Datum(P) (pointer_datum (P))
-
-#define Make_Object(TC, D) \
-((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D)))
-\f
-#ifndef Heap_In_Low_Memory /* Safe version */
-
-typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */
-
-extern Pointer *Memory_Base;
-
-/* The "-1" in the value returned is a guarantee that there is one
- word reserved exclusively for use by the garbage collector. */
-
-#define Allocate_Heap_Space(space) \
- (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- Heap = Memory_Base, \
- ((Memory_Base + (space)) - 1))
-
-#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P))))
-#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base))
-
-#else /* Storing absolute addresses */
-
-typedef long relocation_type; /* Used to relocate pointers on fasload */
-
-#define Allocate_Heap_Space(space) \
- (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \
- ((Heap + (space)) - 1))
-
-#ifdef spectrum
-
-#define Quad1_Tag 0x40000000
-#define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag))
-#define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK))
-
-#else /* Not Spectrum, fast case */
-
-#define Get_Pointer(P) ((Pointer *) (pointer_datum (P)))
-#define C_To_Scheme(P) ((Pointer) (P))
-
-#endif /* spectrum */
-#endif /* Heap_In_Low_Memory */
-\f
-#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
-#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
-
-/* (Make_New_Pointer (TC, A)) may be more efficient than
- (Make_Pointer (TC, (Get_Pointer (A)))) */
-
-#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A)))
-
-#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P)))
-
-#define Store_Address(P, A) \
- P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A))))
-
-#define Address(P) (pointer_datum (P))
-
-/* These are used only where the object is known to be immutable.
- On a parallel processor they don't require atomic references */
-
-#define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N])
-#define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S)
-#define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1)
-#define Fast_User_Vector_Set(P, N, S) Fast_Vector_Set(P, (N)+1, S)
-#define Nth_Vector_Loc(P, N) (&(Fast_Vector_Ref(P, N)))
-#define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0)))
-
-/* General case vector handling requires atomicity for parallel processors */
-
-#define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N))
-#define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S)
-#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
-#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
-\f
-#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
-#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
-#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
-#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
-#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
-#define Get_Integer(P) (pointer_datum (P))
-
-#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0)
-
-#define Sign_Extend(P, S) \
-{ \
- (S) = (Get_Integer (P)); \
- if (((S) & FIXNUM_SIGN_BIT) != 0) \
- (S) |= (-1 << ADDRESS_LENGTH); \
-}
-
-#define Fixnum_Fits(x) \
- ((((x) & SIGN_MASK) == 0) || \
- (((x) & SIGN_MASK) == SIGN_MASK))
-
-/* Playing with the danger bit */
-
-#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT))
-#define Dangerous(P) ((P & DANGER_BIT) != 0)
-#define Clear_Danger_Bit(P) P &= ~DANGER_BIT
-#define Set_Danger_Bit(P) P |= DANGER_BIT
-/* Side effect testing */
-
-#define Is_Constant(address) \
- (((address) >= Constant_Space) && ((address) < Free_Constant))
-
-#define Is_Pure(address) \
- ((Is_Constant (address)) && (Pure_Test (address)))
-
-#define Side_Effect_Impurify(Old_Pointer, Will_Contain) \
-if ((Is_Constant (Get_Pointer (Old_Pointer))) && \
- (GC_Type (Will_Contain) != GC_Non_Pointer) && \
- (! (Is_Constant (Get_Pointer (Will_Contain)))) && \
- (Pure_Test (Get_Pointer (Old_Pointer)))) \
- Primitive_Error (ERR_WRITE_INTO_PURE_SPACE);
-\f
-#ifdef FLOATING_ALIGNMENT
-
-#define FLOATING_BUFFER_SPACE \
- ((FLOATING_ALIGNMENT + 1)/sizeof(Pointer))
-
-#define HEAP_BUFFER_SPACE \
- (TRAP_MAX_IMMEDIATE + 1 + FLOATING_BUFFER_SPACE)
-
-/* The space is there, find the correct position. */
-
-#define Initial_Align_Float(Where) \
-{ \
- while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- Where -= 1; \
-}
-
-#define Align_Float(Where) \
-{ \
- while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \
- *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); \
-}
-
-#else not FLOATING_ALIGNMENT
-
-#define HEAP_BUFFER_SPACE (TRAP_MAX_IMMEDIATE + 1)
-
-#define Initial_Align_Float(Where)
-#define Align_Float(Where)
-
-#endif FLOATING_ALIGNMENT
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
- *
- * Dumps Scheme FASL in user-readable form .
- */
-\f
-#include "scheme.h"
-
-/* These are needed by load.c */
-
-static Pointer *Memory_Base;
-
-#define Load_Data(Count,To_Where) \
- fread(To_Where, sizeof(Pointer), Count, stdin)
-
-#define Reloc_or_Load_Debug true
-
-#include "load.c"
-#include "gctype.c"
-
-#ifdef Heap_In_Low_Memory
-#ifdef spectrum
-#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer))
-#else
-#define File_To_Pointer(P) ((P) / sizeof(Pointer))
-#endif /* spectrum */
-#else
-#define File_To_Pointer(P) (P)
-#endif
-
-#ifndef Conditional_Bug
-#define Relocate(P) \
- (((long) (P) < Const_Base) ? \
- File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
-#else
-#define Relocate_Into(What, P)
-if (((long) (P)) < Const_Base)
- (What) = File_To_Pointer(((long) (P)) - Heap_Base);
-else
- (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
-
-static long Relocate_Temp;
-#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
-#endif
-
-static Pointer *Data, *end_of_memory;
-
-Boolean
-scheme_string(From, Quoted)
-long From;
-Boolean Quoted;
-{ fast long i, Count;
- fast char *Chars;
- Chars = (char *) &Data[From+STRING_CHARS];
- if (Chars < ((char *) end_of_memory))
- { Count = Get_Integer(Data[From+STRING_LENGTH]);
- if (&Chars[Count] < ((char *) end_of_memory))
- { putchar(Quoted ? '\"' : '\'');
- for (i=0; i < Count; i++) printf("%c", *Chars++);
- if (Quoted) putchar('\"');
- putchar('\n');
- return true;
- }
- }
- if (Quoted)
- printf("String not in memory; datum = %x\n", From);
- return false;
-}
-
-#define via(File_Address) Relocate(Address(Data[File_Address]))
-
-void
-scheme_symbol(From)
-long From;
-{ Pointer *symbol;
- symbol = &Data[From+SYMBOL_NAME];
- if ((symbol >= end_of_memory) ||
- !scheme_string(via(From+SYMBOL_NAME), false))
- printf("symbol not in memory; datum = %x\n", From);
- return;
-}
-\f
-Display(Location, Type, The_Datum)
-long Location, Type, The_Datum;
-{ long Points_To;
- printf("%5x: %2x|%6x ", Location, Type, The_Datum);
- if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
- Points_To = Relocate((Pointer *) The_Datum);
- else
- Points_To = The_Datum;
- if (Type > MAX_SAFE_TYPE) printf("*");
- switch (Type & SAFE_TYPE_MASK)
- { /* "Strange" cases */
- case TC_NULL: if (The_Datum == 0)
- { printf("NIL\n");
- return;
- }
- else printf("[NULL ");
- break;
- case TC_TRUE: if (The_Datum == 0)
- { printf("TRUE\n");
- return;
- }
- else printf("[TRUE ");
- break;
- case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
- if (The_Datum == 0)
- Points_To = 0;
- break;
- case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
- Points_To = The_Datum;
- break;
- case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
- Points_To = The_Datum;
- break;
- case TC_INTERNED_SYMBOL: scheme_symbol(Points_To);
- return;
- case TC_UNINTERNED_SYMBOL:
- printf("uninterned ");
- scheme_symbol(Points_To);
- return;
- case TC_CHARACTER_STRING: scheme_string(Points_To, true);
- return;
- case TC_FIXNUM: printf("%d\n", Points_To);
- return;
-
- /* Default cases */
- case TC_LIST: printf("[LIST "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
- case TC_PCOMB2: printf("[PCOMB2 "); break;
- case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
- case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
- case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
- case TC_DELAY: printf("[DELAY "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
- case TC_COMMENT: printf("[COMMENT "); break;
- case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
- case TC_LAMBDA: printf("[LAMBDA "); break;
- case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
- case TC_PCOMB1: printf("[PCOMB1 "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_ACCESS: printf("[ACCESS "); break;
- case TC_DEFINITION: printf("[DEFINITION "); break;
- case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
- case TC_HUNK3: printf("[HUNK3 "); break;
- case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
- case TC_LEXPR: printf("[LEXPR "); break;
- case TC_PCOMB3: printf("[PCOMB3 "); break;
-
- case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB0 "); break;
- case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_CELL: printf("[CELL "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
- case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
- case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
- case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
- case TC_COMPLEX: printf("[COMPLEX "); break;
- case TC_QUAD: printf("[QUAD "); break;
- default: printf("[02x%x ", Type); break;
- }
- printf("%x]\n", Points_To);
-}
-
-main(argc, argv)
-int argc;
-char **argv;
-{ Pointer *Next;
- long i;
- if (argc == 1)
- { if (!Read_Header())
- { fprintf(stderr, "Input does not appear to be in FASL format.\n");
- exit(1);
- }
- printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
- if (Sub_Version >= FASL_LONG_HEADER)
- printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
- }
- else
- { Const_Count = 0;
- sscanf(argv[1], "%x", &Heap_Base);
- sscanf(argv[2], "%x", &Const_Base);
- sscanf(argv[3], "%d", &Heap_Count);
- printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
- Heap_Base, Const_Base, Heap_Count);
- }
- Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
- end_of_memory = &Data[Heap_Count + Const_Count];
- Load_Data(Heap_Count + Const_Count, Data);
- printf("Heap contents\n\n");
- for (Next=Data, i=0; i < Heap_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
- Display(i, Type_Code(*Next), Address(*Next));
- Next += 1;
- for (j=0; j < count ; j++, Next++)
- printf(" %02x%06x\n",
- Type_Code(*Next), Address(*Next));
- i += count;
- Next -= 1;
- }
- else Display(i, Type_Code(*Next), Address(*Next));
- printf("\n\nConstant space\n\n");
- for (; i < Heap_Count+Const_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
- Display(i, Type_Code(*Next), Address(*Next));
- Next += 1;
- for (j=0; j < count ; j++, Next++)
- printf(" %02x%06x\n",
- Type_Code(*Next), Address(*Next));
- i += count;
- Next -= 1;
- }
- else Display(i, Type_Code(*Next), Address(*Next));
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.21 1987/01/22 14:33:52 jinx Rel $
- *
- * This file contains macros and declarations for Bintopsb.c
- * and Psbtobin.c
- *
- */
-\f
-/* These definitions insure that the appropriate code is extracted
- from the included files.
-*/
-
-#include <stdio.h>
-#define fast register
-
-#include "config.h"
-#include "object.h"
-#include "bignum.h"
-#include "gc.h"
-#include "types.h"
-#include "sdata.h"
-#include "const.h"
-#include "gccode.h"
-#include "character.h"
-
-#ifdef HAS_FREXP
-extern double frexp(), ldexp();
-#else
-#include "missing.c"
-#endif
-
-#define PORTABLE_VERSION 1
-
-/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently the dumped object and the external
- primitives vector.
- */
-
-#define NROOTS 2
-
-/* Types to recognize external object references. Any occurrence of these
- (which are external types and thus handled separately) means a reference
- to an external object.
- */
-
-#define CONSTANT_CODE TC_BIG_FIXNUM
-#define HEAP_CODE TC_FIXNUM
-
-#define fixnum_to_bits FIXNUM_LENGTH
-#define bignum_to_bits(len) ((len) * SHIFT)
-#define bits_to_bigdigit(nbits) (((nbits) + (SHIFT-1)) / SHIFT)
-
-#define hex_digits(nbits) (((nbits) + 3) / 4)
-
-#define to_pointer(size) \
- (((size) + (sizeof(Pointer) - 1)) / sizeof(Pointer))
-
-#define bigdigit_to_pointer(ndig) \
- to_pointer((ndig) * sizeof(bigdigit))
-
-/* This assumes that a bignum header is 2 Pointers.
- The bignum code is not very portable, unfortunately */
-
-#define bignum_header_to_pointer Align(0)
-
-#define float_to_pointer \
- to_pointer(sizeof(double))
-#define flonum_to_pointer(nchars) \
- ((nchars) * (1 + float_to_pointer))
-
-#define char_to_pointer(nchars) \
- to_pointer(nchars)
-#define pointer_to_char(npoints) \
- ((npoints) * sizeof(Pointer))
-\f
-/* Global data */
-
-/* If true, make all integers fixnums if possible, and all strings as
- short as possible (trim extra stuff). */
-
-static Boolean Compact_P = true;
-
-/* If true, null out all elements of random non-marked vectors. */
-
-static Boolean Null_NMV = false;
-
-#ifndef Heap_In_Low_Memory
-static Pointer *Memory_Base;
-#endif
-
-static FILE *Input_File, *Output_File;
-
-static char *Program_Name;
-\f
-/* Status flags */
-
-#define COMPACT_P 1
-#define NULL_NMV 2
-
-#define Make_Flags() \
-((Compact_P ? COMPACT_P : 0) | \
- (Null_NMV ? NULL_NMV : 0))
-
-#define Read_Flags(f) \
-Compact_P = ((f) & COMPACT_P); \
-Null_NMV = ((f) & NULL_NMV)
-\f
-/* Argument List Parsing */
-
-struct Option_Struct { char *name;
- Boolean value;
- Boolean *ptr;
- };
-
-Boolean strequal(s1, s2)
-fast char *s1, *s2;
-{ while (*s1 != '\0')
- if (*s1++ != *s2++) return false;
- return (*s2 == '\0');
-}
-
-char *Find_Options(argc, argv, Noptions, Options)
-int argc;
-char **argv;
-int Noptions;
-struct Option_Struct Options[];
-{ for ( ; --argc >= 0; argv++)
- { char *this = *argv;
- int n;
- for (n = 0;
- ((n < Noptions) && (!strequal(this, Options[n].name)));
- n++) ;
- if (n >= Noptions) return this;
- *(Options[n].ptr) = Options[n].value;
- }
- return NULL;
-}
-\f
-/* Usage information */
-
-Print_Options(n, options, where)
-int n;
-struct Option_Struct *options;
-FILE *where;
-{ if (--n < 0) return;
- fprintf(where, "[%s]", options->name);
- options += 1;
- for (; --n >= 0; options += 1)
- fprintf(where, " [%s]", options->name);
- return;
-}
-
-Print_Usage_and_Exit(noptions, options, io_options)
-int noptions;
-struct Option_Struct *options;
-char *io_options;
-{ fprintf(stderr, "usage: %s%s%s",
- Program_Name,
- (((io_options == NULL) ||
- (io_options[0] == '\0')) ? "" : " "),
- io_options);
- if (noptions != 0)
- { putc(' ', stderr);
- Print_Options(noptions, options, stderr);
- }
- putc('\n', stderr);
- exit(1);
-}
-\f
-/* Top level of program */
-
-/* When debugging force arguments on command line */
-
-#ifdef DEBUG
-#undef unix
-#endif
-
-#ifdef unix
-
-/* On unix use io redirection */
-
-Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
- Program_Name = argv[0];
- Input_File = stdin;
- Output_File = stdout;
- if (((argc - 1) > Noptions) ||
- (Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
- Print_Usage_and_Exit(Noptions, Options, "");
- do_it();
- return;
-}
-
-#else
-
-/* Otherwise use command line arguments */
-
-Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
- Program_Name = argv[0];
- if ((argc < 3) ||
- ((argc - 3) > Noptions) ||
- (Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
- Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
- Input_File = ((strequal(argv[1], "-")) ?
- stdin :
- fopen(argv[1], "r"));
- if (Input_File == NULL)
- { perror("Open failed.");
- exit(1);
- }
- Output_File = ((strequal(argv[2], "-")) ?
- stdout :
- fopen(argv[2], "w"));
- if (Output_File == NULL)
- { perror("Open failed.");
- fclose(Input_File);
- exit(1);
- }
- fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
- Program_Name, argv[1], argv[2]);
- do_it();
- fclose(Input_File);
- fclose(Output_File);
- return;
-}
-
-#endif
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.23 1987/04/16 02:06:10 jinx Exp $
- *
- * This File contains the code to translate portable format binary
- * files to internal format.
- *
- */
-\f
-/* Cheap renames */
-
-#define Portable_File Input_File
-#define Internal_File Output_File
-
-#include "translate.h"
-
-static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
-static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
-static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
-static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
-static Pointer *Heap;
-static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
-static Pointer *Constant_Base, *Constant_Table,
- *Constant_Object_Base, *Free_Constant;
-static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
-static Pointer *Stack_Top;
-
-Write_Data(Count, From_Where)
-long Count;
-Pointer *From_Where;
-{ fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
-}
-
-#include "dump.c"
-\f
-#define OUT(c) return ((long) ((c) & MAX_CHAR))
-
-long read_a_char()
-{ fast char C = getc(Portable_File);
- if (C != '\\') OUT(C);
- C = getc(Portable_File);
- switch(C)
- { case 'n': OUT('\n');
- case 't': OUT('\n');
- case 'r': OUT('\r');
- case 'f': OUT('\f');
- case '0': OUT('\0');
- case 'X':
- { long Code;
- fprintf(stderr,
- "%s: File is not Portable. Character Code Found.\n",
- Program_Name);
- fscanf(Portable_File, "%d", &Code);
- getc(Portable_File); /* Space */
- OUT(Code);
- }
- case '\\': OUT('\\');
- default : OUT(C);
- }
-}
-\f
-Pointer *read_a_string(To, Slot)
-Pointer *To, *Slot;
-{ long maxlen, len, Pointer_Count;
- fast char *string = ((char *) (&To[STRING_CHARS]));
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld %ld", &maxlen, &len);
- maxlen += 1; /* Null terminated */
- Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
- To[STRING_HEADER] =
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
- getc(Portable_File); /* Space */
- while (--len >= 0) *string++ = ((char) read_a_char());
- *string = '\0';
- return (To + Pointer_Count);
-}
-\f
-Pointer *read_an_integer(The_Type, To, Slot)
-int The_Type;
-Pointer *To;
-Pointer *Slot;
-{ Boolean negative;
- long size_in_bits;
-
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld", &size_in_bits);
- if ((size_in_bits <= fixnum_to_bits) &&
- (The_Type == TC_FIXNUM))
- { fast long Value = 0;
- fast int Normalization;
- fast long ndigits;
- long digit;
- if (size_in_bits != 0)
- for(Normalization = 0,
- ndigits = hex_digits(size_in_bits);
- --ndigits >= 0;
- Normalization += 4)
- { fscanf(Portable_File, "%1lx", &digit);
- Value += (digit << Normalization);
- }
- if (negative) Value = -Value;
- *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
- return To;
- }
- else if (size_in_bits == 0)
- { bigdigit *REG = BIGNUM(To);
- Prepare_Header(REG, 0, POSITIVE);
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Align(0));
- }
- else
- { fast bigdigit *The_Bignum;
- fast long size, nbits, ndigits;
- fast unsigned long Temp;
- long Length;
- if ((The_Type == TC_FIXNUM) && (!Compact_P))
- fprintf(stderr,
- "%s: Fixnum too large, coercing to bignum.\n",
- Program_Name);
- size = bits_to_bigdigit(size_in_bits);
- ndigits = hex_digits(size_in_bits);
- Length = Align(size);
- The_Bignum = BIGNUM(To);
- Prepare_Header(The_Bignum, size, (negative ? NEGATIVE : POSITIVE));
- for (The_Bignum = Bignum_Bottom(The_Bignum), nbits = 0, Temp = 0;
- --size >= 0;
- )
- { for ( ;
- (nbits < SHIFT) && (ndigits > 0);
- ndigits -= 1, nbits += 4)
- { long digit;
- fscanf(Portable_File, "%1lx", &digit);
- Temp |= (((unsigned long) digit) << nbits);
- }
- *The_Bignum++ = Rem_Radix(Temp);
- Temp = Div_Radix(Temp);
- nbits -= SHIFT;
- }
- *Slot = Make_Pointer(TC_BIG_FIXNUM, To);
- return (To + Length);
- }
-}
-\f
-/* Underflow and Overflow */
-
-/* dflmax and dflmin exist in the Berserkely FORTRAN library */
-
-static double the_max = 0.0;
-
-#define dflmin() 0.0 /* Cop out */
-#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
-
-double compute_max()
-{ fast double Result = 0.0;
- fast int expt;
- for (expt = MAX_FLONUM_EXPONENT;
- expt != 0;
- expt >>= 1)
- Result += ldexp(1.0, expt);
- the_max = Result;
- return Result;
-}
-\f
-double read_a_flonum()
-{ Boolean negative;
- long size_in_bits, exponent;
- fast double Result;
-
- getc(Portable_File); /* Space */
- negative = ((getc(Portable_File)) == '-');
- fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
- if (size_in_bits == 0) Result = 0.0;
- else if ((exponent > MAX_FLONUM_EXPONENT) ||
- (exponent < -MAX_FLONUM_EXPONENT))
- { /* Skip over mantissa */
- while (getc(Portable_File) != '\n') ;
- fprintf(stderr,
- "%s: Floating point exponent too %s!\n",
- Program_Name,
- ((exponent < 0) ? "small" : "large"));
- Result = ((exponent < 0) ? dflmin() : dflmax());
- }
- else
- { fast long ndigits;
- fast double Normalization;
- long digit;
- if (size_in_bits > FLONUM_MANTISSA_BITS)
- fprintf(stderr,
- "%s: Some precision may be lost.",
- Program_Name);
- getc(Portable_File); /* Space */
- for (ndigits = hex_digits(size_in_bits),
- Result = 0.0,
- Normalization = (1.0 / 16.0);
- --ndigits >= 0;
- Normalization /= 16.0)
- {
- fscanf(Portable_File, "%1lx", &digit);
- Result += (((double ) digit) * Normalization);
- }
- Result = ldexp(Result, ((int) exponent));
- }
- if (negative) Result = -Result;
- return Result;
-}
-\f
-Pointer *
-Read_External(N, Table, To)
- long N;
- fast Pointer *Table, *To;
-{
- fast Pointer *Until = &Table[N];
- int The_Type;
-
- while (Table < Until)
- {
- fscanf(Portable_File, "%2x", &The_Type);
- switch(The_Type)
- {
- case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
- continue;
- case TC_FIXNUM:
- case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
- continue;
- case TC_CHARACTER:
- {
- long the_char_code;
-
- getc(Portable_File); /* Space */
- fscanf( Portable_File, "%3x", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
- continue;
- }
- case TC_BIG_FLONUM:
- {
- double The_Flonum = read_a_flonum();
-
- Align_Float(To);
- *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
- *((double *) To) = The_Flonum;
- To += float_to_pointer;
- continue;
- }
- default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
- exit(1);
- }
- }
- return To;
-}
-\f
-#if false
-Move_Memory(From, N, To)
-fast Pointer *From, *To;
-long N;
-{ fast Pointer *Until = &From[N];
- while (From < Until) *To++ = *From++;
- return;
-}
-#endif
-
-Relocate_Objects(From, N, disp)
-fast Pointer *From;
-long N;
-fast long disp;
-{ fast Pointer *Until = &From[N];
- while (From < Until)
- { switch(Type_Code(*From))
- { case TC_FIXNUM:
- case TC_CHARACTER:
- From += 1;
- break;
- case TC_BIG_FIXNUM:
- case TC_BIG_FLONUM:
- case TC_CHARACTER_STRING:
- *From++ == Make_Object(Type_Code(*From), (disp + Datum(*From)));
- break;
- default:
- fprintf(stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- Program_Name,
- Type_Code(*From));
- }
- }
-}
-\f
-#define Relocate_Into(Where, Addr) \
-if ((Addr) < Dumped_Pure_Base) \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
-else if ((Addr) < Dumped_Constant_Base) \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
-else (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base];
-
-#ifndef Conditional_Bug
-
-#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
- &Constant_Base[(Addr) - Dumped_Constant_Base]))
-
-#else
-static Pointer *Relocate_Temp;
-#define Relocate(Addr) \
- (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
-#endif
-
-Pointer *Read_Pointers_and_Relocate(N, To)
-fast long N;
-fast Pointer *To;
-{ int The_Type;
- long The_Datum;
-/* Align_Float(To); */
- while (--N >= 0)
- { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- switch(The_Type)
- { case CONSTANT_CODE:
- *To++ = Constant_Table[The_Datum];
- continue;
-
- case HEAP_CODE:
- *To++ = Heap_Table[The_Datum];
- continue;
-
- case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV)) /* Unknown object! */
- fprintf(stderr, "%s: File is not portable: NMH found\n",
- Program_Name);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- { fast long count = The_Datum;
- N -= count;
- while (--count >= 0)
- { fscanf(Portable_File, "%2x %lx", &The_Type, &The_Datum);
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- }
- }
- continue;
-
- case TC_BROKEN_HEART:
- if (The_Datum != 0)
- { fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
- exit(1);
- }
- /* Fall Through */
- case TC_PRIMITIVE_EXTERNAL:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_simple_Non_Pointer:
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- continue;
-
- case TC_REFERENCE_TRAP:
- if (The_Datum <= TRAP_MAX_IMMEDIATE)
- {
- *To++ = Make_Non_Pointer(The_Type, The_Datum);
- continue;
- }
- /* It is a pointer, fall through. */
- default:
- /* Should be stricter */
- *To++ = Make_Pointer(The_Type, Relocate(The_Datum));
- continue;
- }
- }
-/* Align_Float(To); */
- return To;
-}
-\f
-#ifdef DEBUG
-Print_External_Objects(area_name, Table, N)
-char *area_name;
-fast Pointer *Table;
-fast long N;
-{ fast Pointer *Table_End = &Table[N];
-
- fprintf(stderr, "%s External Objects:\n", area_name);
- fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
-
- for( ; Table < Table_End; Table++)
- switch (Type_Code(*Table))
- { case TC_FIXNUM:
- { long The_Number;
- Sign_Extend(*Table, The_Number);
- fprintf(stderr,
- "Table[%6d] = Fixnum %d\n",
- (N-(Table_End-Table)),
- The_Number);
- break;
- }
- case TC_CHARACTER:
- fprintf(stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N-(Table_End-Table)),
- Get_Integer(*Table),
- Get_Integer(*Table));
- break;
-
-/* Print_External_Objects continues on the next page */
-\f
-/* Print_External_Objects, continued */
-
- case TC_CHARACTER_STRING:
- fprintf(stderr,
- "Table[%6d] = string \"%s\"\n",
- (N-(Table_End-Table)),
- ((char *) Nth_Vector_Loc(*Table, STRING_CHARS)));
- break;
- case TC_BIG_FIXNUM:
- fprintf(stderr,
- "Table[%6d] = Bignum\n",
- (N-(Table_End-Table)));
- break;
- case TC_BIG_FLONUM:
- fprintf(stderr,
- "Table[%6d] = Flonum %lf\n",
- (N-(Table_End-Table)),
- (* ((double *) Nth_Vector_Loc(*Table, 1))));
- break;
- default:
- fprintf(stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N-(Table_End-Table)),
- *Table);
- break;
- }
-}
-#endif
-\f
-long Read_Header_and_Allocate()
-{ long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NStrings, NBits, NChars;
- long Size;
-
- /* Read Header */
-
- fscanf(Input_File, "%ld %ld %ld %ld",
- &Portable_Version, &Flags, &Version, &Sub_Version);
- fscanf(Input_File, "%ld %ld %ld",
- &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
- fscanf(Input_File, "%ld %ld %ld",
- &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
- fscanf(Input_File, "%ld %ld %ld",
- &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
- fscanf(Input_File, "%ld %ld %ld %ld %ld",
- &NFlonums, &NIntegers, &NStrings, &NBits, &NChars);
- fscanf(Input_File, "%ld %ld",
- &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
-
- if ((Portable_Version != PORTABLE_VERSION) ||
- (Version != FASL_FORMAT_VERSION) ||
- (Sub_Version != FASL_SUBVERSION))
- { fprintf(stderr,
- "FASL File Version %4d Subversion %4d Portable Version %4d\n",
- Version, Sub_Version , Portable_Version);
- fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
- exit(1);
- }
-
- Read_Flags(Flags);
-
- Size = (6 + /* SNMV */
- HEAP_BUFFER_SPACE +
- Heap_Count + Heap_Objects +
- Constant_Count + Constant_Objects +
- Pure_Count + Pure_Objects +
- flonum_to_pointer(NFlonums) +
- ((NIntegers * bignum_header_to_pointer) +
- (bigdigit_to_pointer(bits_to_bigdigit(NBits)))) +
- ((NStrings * STRING_CHARS) + (char_to_pointer(NChars))));
-
- Allocate_Heap_Space(Size);
- if (Heap == NULL)
- { fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
- Program_Name, Size);
- exit(1);
- }
- Heap += HEAP_BUFFER_SPACE;
- Initial_Align_Float(Heap);
- return (Size - HEAP_BUFFER_SPACE);
-}
-\f
-do_it()
-{ long Size;
- Size = Read_Header_and_Allocate();
- Stack_Top = &Heap[Size];
-
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- Heap_Object_Base =
- Read_External(Heap_Objects, Heap_Table, Heap_Base);
-
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
- Pure_Object_Base =
- Read_External(Pure_Objects, Pure_Table, Pure_Base);
-
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
- Constant_Object_Base =
- Read_External(Constant_Objects, Constant_Table, Constant_Base);
-
-#ifdef DEBUG
- Print_External_Objects("Heap", Heap_Table, Heap_Objects);
- Print_External_Objects("Pure", Pure_Table, Pure_Objects);
- Print_External_Objects("Constant", Constant_Table, Constant_Objects);
-#endif
-\f
- /* Read the normal objects */
-
- Free =
- Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
- Free_Pure =
- Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
- Free_Constant =
- Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
-
- /* Dump the objects */
-
- { Pointer *Dumped_Object, *Dumped_Ext_Prim;
- Relocate_Into(Dumped_Object, Dumped_Object_Addr);
- Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumping:\n");
- fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base));
- fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base));
- fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base));
- fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object);
- fprintf(stderr,
- "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
- Dumped_Ext_Prim, *Dumped_Ext_Prim);
-#endif
-
- /* Is there a Pure/Constant block? */
-
- if ((Constant_Objects == 0) && (Constant_Count == 0) &&
- (Pure_Objects == 0) && (Pure_Count == 0))
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
- else
- { long Pure_Length = (Constant_Base - Pure_Base) + 1;
- long Total_Length = (Free_Constant - Pure_Base) + 4;
- Pure_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, (Pure_Length - 1));
- Pure_Base[-1] =
- Make_Non_Pointer(PURE_PART, Total_Length);
- Constant_Base[-2] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Constant_Base[-1] =
- Make_Non_Pointer(CONSTANT_PART, (Pure_Length - 1));
- Free_Constant[0] =
- Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- Free_Constant[1] =
- Make_Non_Pointer(END_OF_BLOCK, Total_Length);
-
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
- }
- }
- return;
-}
-\f
-/* Top level */
-
-static int Noptions = 0;
-/* C does not usually like empty initialized arrays, so ... */
-static struct Option_Struct Options[] = {{"dummy", true, NULL}};
-
-main(argc, argv)
-int argc;
-char *argv[];
-{ Setup_Program(argc, argv, Noptions, Options);
- return;
-}
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $
- *
- * Return codes. These are placed in Return when an
- * interpreter operation needs to operate in several
- * phases. This must correspond with UTABMD.SCM
- *
- */
-\f
-/* These names are also in storage.c.
- * Please maintain consistency.
- */
-
-#define RC_END_OF_COMPUTATION 0x00
-/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
-#define RC_JOIN_STACKLETS 0x01
-#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
-#define RC_INTERNAL_APPLY 0x03
-#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
-#define RC_RESTORE_HISTORY 0x05
-#define RC_INVOKE_STACK_THREAD 0x06
-#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
-#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
-#define RC_EXECUTE_DEFINITION_FINISH 0x09
-#define RC_EXECUTE_ACCESS_FINISH 0x0A
-#define RC_EXECUTE_IN_PACKAGE_CONTINUE 0x0B
-#define RC_SEQ_2_DO_2 0x0C
-#define RC_SEQ_3_DO_2 0x0D
-#define RC_SEQ_3_DO_3 0x0E
-#define RC_CONDITIONAL_DECIDE 0x0F
-#define RC_DISJUNCTION_DECIDE 0x10
-#define RC_COMB_1_PROCEDURE 0x11
-#define RC_COMB_APPLY_FUNCTION 0x12
-#define RC_COMB_2_FIRST_OPERAND 0x13
-#define RC_COMB_2_PROCEDURE 0x14
-#define RC_COMB_SAVE_VALUE 0x15
-#define RC_PCOMB1_APPLY 0x16
-#define RC_PCOMB2_DO_1 0x17
-#define RC_PCOMB2_APPLY 0x18
-#define RC_PCOMB3_DO_2 0x19
-#define RC_PCOMB3_DO_1 0x1A
-#define RC_PCOMB3_APPLY 0x1B
-\f
-#define RC_SNAP_NEED_THUNK 0x1C
-#define RC_REENTER_COMPILED_CODE 0x1D
-/* formerly RC_GET_CHAR_REPEAT 0x1E */
-#define RC_COMP_REFERENCE_RESTART 0x1F
-#define RC_NORMAL_GC_DONE 0x20
-#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
-#define RC_PURIFY_GC_1 0x22
-#define RC_PURIFY_GC_2 0x23
-#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
-#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
-/* formerly RC_GET_CHAR 0x26 */
-/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
-#define RC_COMP_ASSIGNMENT_RESTART 0x28
-#define RC_POP_FROM_COMPILED_CODE 0x29
-#define RC_RETURN_TRAP_POINT 0x2A
-#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
-#define RC_RESTORE_TO_STATE_POINT 0x2C
-#define RC_MOVE_TO_ADJACENT_POINT 0x2D
-#define RC_RESTORE_VALUE 0x2E
-#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
-
-/* The following are not used in the 68000 implementation */
-
-#define RC_POP_RETURN_ERROR 0x40
-#define RC_EVAL_ERROR 0x41
-#define RC_REPEAT_PRIMITIVE 0x42
-#define RC_COMP_INTERRUPT_RESTART 0x43
-/* formerly RC_COMP_RECURSION_GC 0x44 */
-#define RC_RESTORE_INT_MASK 0x45
-#define RC_HALT 0x46
-#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
-#define RC_REPEAT_DISPATCH 0x48
-#define RC_GC_CHECK 0x49
-#define RC_RESTORE_FLUIDS 0x4A
-#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B
-#define RC_COMP_ACCESS_RESTART 0x4C
-#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
-#define RC_COMP_UNBOUND_P_RESTART 0x4E
-#define RC_COMP_DEFINITION_RESTART 0x4F
-#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
-
-#define MAX_RETURN_CODE 0x50
-
-/* When adding return codes, don't forget to update storage.c too. */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */
-\f
-/* Kinds of traps:
-
- Note that for every trap there is a dangerous version.
- The danger bit is the bottom bit of the trap number,
- thus all dangerous traps are odd and viceversa.
-
- For efficiency, some traps are immediate, while some are
- pointer objects. The type code is multiplexed, and the
- garbage collector handles it specially.
-
- */
-
-/* The following are immediate traps: */
-
-#define TRAP_UNASSIGNED 0
-#define TRAP_UNASSIGNED_DANGEROUS 1
-#define TRAP_UNBOUND 2
-#define TRAP_UNBOUND_DANGEROUS 3
-#define TRAP_ILLEGAL 4
-#define TRAP_ILLEGAL_DANGEROUS 5 /* Unused. */
-
-/* TRAP_MAX_IMMEDIATE is defined in const.h */
-
-/* The following are not: */
-
-#define TRAP_NOP 10 /* Unused. */
-#define TRAP_DANGEROUS 11
-#define TRAP_FLUID 12
-#define TRAP_FLUID_DANGEROUS 13
-
-/* Trap utilities */
-
-#define get_trap_kind(variable, what) \
-{ \
- variable = Datum(what); \
- if (variable > TRAP_MAX_IMMEDIATE) \
- variable = Datum(Vector_Ref(what, TRAP_TAG)); \
-}
-\f
-/* Common constants */
-
-#ifndef b32
-#define UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED)
-#define DANGEROUS_UNASSIGNED_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNASSIGNED_DANGEROUS)
-#define UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND)
-#define DANGEROUS_UNBOUND_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_UNBOUND_DANGEROUS)
-#define ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL)
-#define DANGEROUS_ILLEGAL_OBJECT Make_Non_Pointer(TC_REFERENCE_TRAP, TRAP_ILLEGAL_DANGEROUS)
-#else
-#define UNASSIGNED_OBJECT 0x32000000
-#define DANGEROUS_UNASSIGNED_OBJECT 0x32000001
-#define UNBOUND_OBJECT 0x32000002
-#define DANGEROUS_UNBOUND_OBJECT 0x32000003
-#define ILLEGAL_OBJECT 0x32000004
-#define DANGEROUS_ILLEGAL_OBJECT 0x32000005
-#endif
-
-#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
-
-#if (TC_REFERENCE_TRAP != 0x32)
-#include "error: trap.h and types.h are inconsistent"
-#endif
-
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.22 1987/04/03 00:21:38 jinx Exp $
- *
- * Type code definitions, numerical order
- *
- */
-\f
-#define TC_NULL 0x00
-#define TC_LIST 0x01
-#define TC_CHARACTER 0x02
-#define TC_SCODE_QUOTE 0x03
-#define TC_PCOMB2 0x04
-#define TC_UNINTERNED_SYMBOL 0x05
-#define TC_BIG_FLONUM 0x06
-#define TC_COMBINATION_1 0x07
-#define TC_TRUE 0x08
-#define TC_EXTENDED_PROCEDURE 0x09
-#define TC_VECTOR 0x0A
-#define TC_RETURN_CODE 0x0B
-#define TC_COMBINATION_2 0x0C
-#define TC_COMPILED_PROCEDURE 0x0D
-#define TC_BIG_FIXNUM 0x0E
-#define TC_PROCEDURE 0x0F
-#define TC_PRIMITIVE_EXTERNAL 0x10
-#define TC_DELAY 0x11
-#define TC_ENVIRONMENT 0x12
-#define TC_DELAYED 0x13
-#define TC_EXTENDED_LAMBDA 0x14
-#define TC_COMMENT 0x15
-#define TC_NON_MARKED_VECTOR 0x16
-#define TC_LAMBDA 0x17
-#define TC_PRIMITIVE 0x18
-#define TC_SEQUENCE_2 0x19
-\f
-#define TC_FIXNUM 0x1A
-#define TC_PCOMB1 0x1B
-#define TC_CONTROL_POINT 0x1C
-#define TC_INTERNED_SYMBOL 0x1D
-#define TC_CHARACTER_STRING 0x1E
-#define TC_ACCESS 0x1F
-/* UNUSED 0x20 */ /* Used to be EXTENDED_FIXNUM. */
-#define TC_DEFINITION 0x21
-#define TC_BROKEN_HEART 0x22
-#define TC_ASSIGNMENT 0x23
-#define TC_HUNK3 0x24
-#define TC_IN_PACKAGE 0x25
-#define TC_COMBINATION 0x26
-#define TC_MANIFEST_NM_VECTOR 0x27
-#define TC_COMPILED_EXPRESSION 0x28
-#define TC_LEXPR 0x29
-#define TC_PCOMB3 0x2A
-#define TC_MANIFEST_SPECIAL_NM_VECTOR 0x2B
-#define TC_VARIABLE 0x2C
-#define TC_THE_ENVIRONMENT 0x2D
-#define TC_FUTURE 0x2E
-#define TC_VECTOR_1B 0x2F
-#define TC_PCOMB0 0x30
-#define TC_VECTOR_16B 0x31
-#define TC_REFERENCE_TRAP 0x32 /* Used to be UNASSIGNED. */
-#define TC_SEQUENCE_3 0x33
-#define TC_CONDITIONAL 0x34
-#define TC_DISJUNCTION 0x35
-#define TC_CELL 0x36
-#define TC_WEAK_CONS 0x37
-#define TC_QUAD 0x38 /* Used to be TC_TRAP. */
-#define TC_RETURN_ADDRESS 0x39
-#define TC_COMPILER_LINK 0x3A
-#define TC_STACK_ENVIRONMENT 0x3B
-#define TC_COMPLEX 0x3C
-
-/* If you add a new type, don't forget to update gccode.h and gctype.c */
-
-/* Aliases */
-
-#define TC_FALSE TC_NULL
-#define TC_MANIFEST_VECTOR TC_NULL
-#define GLOBAL_ENV TC_NULL
-#define TC_BIT_STRING TC_VECTOR_1B
-#define TC_VECTOR_8B TC_CHARACTER_STRING
-#define TC_ADDRESS TC_FIXNUM
+++ /dev/null
-;;; -*-Scheme-*-
-;;;
-;;; Copyright (c) 1987 Massachusetts Institute of Technology
-;;;
-;;; This material was developed by the Scheme project at the
-;;; Massachusetts Institute of Technology, Department of
-;;; Electrical Engineering and Computer Science. Permission to
-;;; copy this software, to redistribute it, and to use it for any
-;;; purpose is granted, subject to the following restrictions and
-;;; understandings.
-;;;
-;;; 1. Any copy made of this software must include this copyright
-;;; notice in full.
-;;;
-;;; 2. Users of this software agree to make their best efforts (a)
-;;; to return to the MIT Scheme project any improvements or
-;;; extensions that they make, so that these may be included in
-;;; future releases; and (b) to inform MIT of noteworthy uses of
-;;; this software.
-;;;
-;;; 3. All materials developed as a consequence of the use of this
-;;; software shall duly acknowledge such use, in accordance with
-;;; the usual standards of acknowledging credit in academic
-;;; research.
-;;;
-;;; 4. MIT has made no warrantee or representation that the
-;;; operation of this software will be error-free, and MIT is
-;;; under no obligation to provide any services, by way of
-;;; maintenance, update, or otherwise.
-;;;
-;;; 5. In conjunction with products arising from the use of this
-;;; material, there shall be no use of the name of the
-;;; Massachusetts Institute of Technology nor of any adaptation
-;;; thereof in any advertising, promotional, or sales literature
-;;; without prior written consent from MIT in each case.
-;;;
-
-;;;; Machine Dependent Type Tables
-
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $
-
-(declare (usual-integrations))
-
-;;; For quick access to any given table,
-;;; search for the following strings:
-;;;
-;;; [] Fixed
-;;; [] Types
-;;; [] Returns
-;;; [] Primitives
-;;; [] External
-;;; [] Errors
-;;; [] Identification
-\f
-;;; [] Fixed
-
-(vector-set! (get-fixed-objects-vector)
- #x0F ;(fixed-objects-vector-slot 'MICROCODE-FIXED-OBJECTS-SLOTS)
- #(NON-OBJECT ;00
- SYSTEM-INTERRUPT-VECTOR ;01
- SYSTEM-ERROR-VECTOR ;02
- OBARRAY ;03
- MICROCODE-TYPES-VECTOR ;04
- MICROCODE-RETURNS-VECTOR ;05
- MICROCODE-PRIMITIVES-VECTOR ;06
- MICROCODE-ERRORS-VECTOR ;07
- MICROCODE-IDENTIFICATION-VECTOR ;08
- #F ;09
- #F ;0A
- GC-DAEMON ;0B
- TRAP-HANDLER ;0C
- #F ;0D
- STEPPER-STATE ;0E
- MICROCODE-FIXED-OBJECTS-SLOTS ;0F
- MICROCODE-EXTERNAL-PRIMITIVES ;10
- STATE-SPACE-TAG ;11
- STATE-POINT-TAG ;12
- DUMMY-HISTORY ;13
- BIGNUM-ONE ;14
- SCHEDULER ;15
- MICROCODE-TERMINATIONS-VECTOR ;16
- MICROCODE-TERMINATIONS-PROCEDURES ;17
- FIXED-OBJECTS-VECTOR ;18
- THE-WORK-QUEUE ;19
- FUTURE-READS-LOGGER ;1A
- TOUCHED-FUTURES-VECTOR ;1B
- PRECIOUS-OBJECTS ;1C
- ERROR-PROCEDURE ;1D
- UNSNAPPED-LINK ;1E
- MICROCODE-UTILITIES-VECTOR ;1F
- COMPILER-ERROR-PROCEDURE ;20
- LOST-OBJECT-BASE ;21
- STATE-SPACE-ROOT ;22
- MICROCODE-TABLE-IDENTIFICATION ;23
- ))
-\f
-;;; [] Types
-
-(vector-set! (get-fixed-objects-vector)
- 4 ;(fixed-objects-vector-slot 'MICROCODE-TYPES-VECTOR)
- #((NULL FALSE MANIFEST-VECTOR GLOBAL-ENVIRONMENT) ;00
- (PAIR LIST) ;01
- CHARACTER ;02
- QUOTATION ;03
- PRIMITIVE-COMBINATION-2 ;04
- UNINTERNED-SYMBOL ;05
- (FLONUM BIG-FLONUM) ;06
- COMBINATION-1 ;07
- TRUE ;08
- EXTENDED-PROCEDURE ;09
- VECTOR ;0A
- RETURN-ADDRESS ;0B
- COMBINATION-2 ;0C
- COMPILED-PROCEDURE ;0D
- (BIGNUM BIG-FIXNUM) ;0E
- PROCEDURE ;0F
- PRIMITIVE-EXTERNAL ;10
- DELAY ;11
- ENVIRONMENT ;12
- DELAYED ;13
- EXTENDED-LAMBDA ;14
- COMMENT ;15
- NON-MARKED-VECTOR ;16
- LAMBDA ;17
- PRIMITIVE ;18
- SEQUENCE-2 ;19
- (FIXNUM ADDRESS) ;1A
- PRIMITIVE-COMBINATION-1 ;1B
- CONTROL-POINT ;1C
- INTERNED-SYMBOL ;1D
- (STRING CHARACTER-STRING VECTOR-8B) ;1E
- ACCESS ;1F
- #F ;20
- DEFINITION ;21
- BROKEN-HEART ;22
- ASSIGNMENT ;23
- (TRIPLE HUNK3) ;24
- IN-PACKAGE ;25
- COMBINATION ;26
- MANIFEST-NM-VECTOR ;27
- COMPILED-EXPRESSION ;28
- LEXPR ;29
- PRIMITIVE-COMBINATION-3 ;2A
- MANIFEST-SPECIAL-NM-VECTOR ;2B
- VARIABLE ;2C
- THE-ENVIRONMENT ;2D
- FUTURE ;2E
- VECTOR-1B ;2F
- PRIMITIVE-COMBINATION-0 ;30
- VECTOR-16B ;31
- (REFERENCE-TRAP UNASSIGNED) ;32
- SEQUENCE-3 ;33
- CONDITIONAL ;34
- DISJUNCTION ;35
- CELL ;36
- WEAK-CONS ;37
- QUAD ;38
- COMPILER-RETURN-ADDRESS ;39
- COMPILER-LINK ;3A
- STACK-ENVIRONMENT ;3B
- COMPLEX ;3C
- #F ;3D
- #F ;3E
- #F ;3F
- #F ;40
- #F ;41
- #F ;42
- #F ;43
- #F ;44
- #F ;45
- #F ;46
- #F ;47
- #F ;48
- #F ;49
- #F ;4A
- #F ;4B
- #F ;4C
- #F ;4D
- #F ;4E
- #F ;4F
- #F ;50
- #F ;51
- #F ;52
- #F ;53
- #F ;54
- #F ;55
- #F ;56
- #F ;57
- #F ;58
- #F ;59
- #F ;5A
- #F ;5B
- #F ;5C
- #F ;5D
- #F ;5E
- #F ;5F
- #F ;60
- #F ;61
- #F ;62
- #F ;63
- #F ;64
- #F ;65
- #F ;66
- #F ;67
- #F ;68
- #F ;69
- #F ;6A
- #F ;6B
- #F ;6C
- #F ;6D
- #F ;6E
- #F ;6F
- #F ;70
- #F ;71
- #F ;72
- #F ;73
- #F ;74
- #F ;75
- #F ;76
- #F ;77
- #F ;78
- #F ;79
- #F ;7A
- #F ;7B
- #F ;7C
- #F ;7D
- #F ;7E
- #F ;7F
- ))
-\f
-;;; [] Returns
-
-(vector-set! (get-fixed-objects-vector)
- 5 ;(fixed-objects-vector-slot 'MICROCODE-RETURNS-VECTOR)
- #(NON-EXISTENT-CONTINUATION ;00
- JOIN-STACKLETS ;01
- RESTORE-CONTINUATION ;02
- INTERNAL-APPLY ;03
- BAD-INTERRUPT-CONTINUE ;04
- RESTORE-HISTORY ;05
- INVOKE-STACK-THREAD ;06
- RESTART-EXECUTION ;07
- ASSIGNMENT-CONTINUE ;08
- DEFINITION-CONTINUE ;09
- ACCESS-CONTINUE ;0A
- IN-PACKAGE-CONTINUE ;0B
- SEQUENCE-2-SECOND ;0C
- SEQUENCE-3-SECOND ;0D
- SEQUENCE-3-THIRD ;0E
- CONDITIONAL-DECIDE ;0F
- DISJUNCTION-DECIDE ;10
- COMBINATION-1-PROCEDURE ;11
- COMBINATION-APPLY ;12
- COMBINATION-2-FIRST-OPERAND ;13
- COMBINATION-2-PROCEDURE ;14
- COMBINATION-SAVE-VALUE ;15
- PRIMITIVE-COMBINATION-1-APPLY ;16
- PRIMITIVE-COMBINATION-2-FIRST-OPERAND ;17
- PRIMITIVE-COMBINATION-2-APPLY ;18
- PRIMITIVE-COMBINATION-3-SECOND-OPERAND ;19
- PRIMITIVE-COMBINATION-3-FIRST-OPERAND ;1A
- PRIMITIVE-COMBINATION-3-APPLY ;1B
- FORCE-SNAP-THUNK ;1C
- REENTER-COMPILED-CODE ;1D
- #F ;1E
- COMPILER-REFERENCE-RESTART ;1F
- NORMAL-GARBAGE-COLLECT-DONE ;20
- COMPLETE-GARBAGE-COLLECT-DONE ;21
- PURIFY-AFTER-FIRST-GC ;22
- PURIFY-AFTER-SECOND-GC ;23
- AFTER-MEMORY-UPDATE ;24
- RETRY-MICROCODE-TERMINATION-RESTARTABLE ;25
- #F ;26
- #F ;27
- COMPILER-ASSIGNMENT-RESTART ;28
- POP-FROM-COMPILED-CODE ;29
- RETURN-TRAP-POINT ;2A
- RESTORE-STEPPER ;2B
- RESTORE-TO-STATE-POINT ;2C
- MOVE-TO-ADJACENT-POINT ;2D
- RESTORE-VALUE ;2E
- RESTORE-DONT-COPY-HISTORY ;2F
- #F ;30
- #F ;31
- #F ;32
- #F ;33
- #F ;34
- #F ;35
- #F ;36
- #F ;37
- #F ;38
- #F ;39
- #F ;3A
- #F ;3B
- #F ;3C
- #F ;3D
- #F ;3E
- #F ;3F
- POP-RETURN-ERROR ;40
- EVAL-ERROR ;41
- REPEAT-PRIMITIVE ;42
- COMPILER-INTERRUPT-RESTART ;43
- #F ;44
- RESTORE-INTERRUPT-MASK ;45
- HALT ;46
- FINISH-GLOBAL-INTERRUPT ;47
- REPEAT-DISPATCH ;48
- GC-CHECK ;49
- RESTORE-FLUIDS ;4A
- COMPILER-LOOKUP-APPLY-RESTART ;4B
- COMPILER-ACCESS-RESTART ;4C
- COMPILER-UNASSIGNED?-RESTART ;4D
- COMPILER-UNBOUND?-RESTART ;4E
- COMPILER-DEFINITION-RESTART ;4F
- COMPILER-LEXPR-INTERRUPT-RESTART ;50
- ))
-\f
-;;; [] Primitives
-
-(vector-set! (get-fixed-objects-vector)
- 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)
- #(LEXICAL-ASSIGNMENT ;$00
- LOCAL-REFERENCE ;$01
- LOCAL-ASSIGNMENT ;$02
- CALL-WITH-CURRENT-CONTINUATION ;$03
- SCODE-EVAL ;$04
- APPLY ;$05
- SET-INTERRUPT-ENABLES! ;$06
- STRING->SYMBOL ;$07
- GET-WORK ;$08
- NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09
- CURRENT-DYNAMIC-STATE ;$0A
- SET-CURRENT-DYNAMIC-STATE! ;$0B
- (NULL? NOT FALSE?) ;$0C
- EQ? ;$0D
- STRING-EQUAL? ;$0E
- PRIMITIVE-TYPE? ;$0F
- PRIMITIVE-TYPE ;$10
- PRIMITIVE-SET-TYPE ;$11
- LEXICAL-REFERENCE ;$12
- LEXICAL-UNREFERENCEABLE? ;$13
- MAKE-CHAR ;$14
- CHAR-BITS ;$15
- EXIT ;$16
- CHAR-CODE ;$17
- LEXICAL-UNASSIGNED? ;$18
- INSERT-NON-MARKED-VECTOR! ;$19
- HALT ;$1A
- CHAR->INTEGER ;$1B
- MEMQ ;$1C
- INSERT-STRING ;$1D
- ENABLE-INTERRUPTS! ;$1E
- MAKE-EMPTY-STRING ;$1F
- CONS ;$20
- (CAR FIRST) ;$21
- (CDR FIRST-TAIL) ;$22
- (SET-CAR! SET-FIRST!) ;$23
- (SET-CDR! SET-FIRST-TAIL!) ;$24
- #F ;$25
- TTY-GET-CURSOR ;$26
- GENERAL-CAR-CDR ;$27
- HUNK3-CONS ;$28
- HUNK3-CXR ;$29
- HUNK3-SET-CXR! ;$2A
- INSERT-STRING! ;$2B
- VECTOR-CONS ;$2C
- (VECTOR-LENGTH VECTOR-SIZE) ;$2D
- VECTOR-REF ;$2E
- SET-CURRENT-HISTORY! ;$2F
- VECTOR-SET! ;$30
- NON-MARKED-VECTOR-CONS ;$31
- #F ;$32
- LEXICAL-UNBOUND? ;$33
- INTEGER->CHAR ;$34
- CHAR-DOWNCASE ;$35
- CHAR-UPCASE ;$36
- ASCII->CHAR ;$37
- CHAR-ASCII? ;$38
- CHAR->ASCII ;$39
- GARBAGE-COLLECT ;$3A
- PLUS-FIXNUM ;$3B
- MINUS-FIXNUM ;$3C
- MULTIPLY-FIXNUM ;$3D
- DIVIDE-FIXNUM ;$3E
- EQUAL-FIXNUM? ;$3F
- LESS-THAN-FIXNUM? ;$40
- POSITIVE-FIXNUM? ;$41
- ONE-PLUS-FIXNUM ;$42
- MINUS-ONE-PLUS-FIXNUM ;$43
- TRUNCATE-STRING! ;$44
- SUBSTRING ;$45
- ZERO-FIXNUM? ;$46
- MAKE-OBJECT-SAFE ;$47
- MAKE-OBJECT-DANGEROUS ;$48
- OBJECT-DANGEROUS? ;$49
- SUBSTRING->LIST ;$4A
- MAKE-FILLED-STRING ;$4B
- PLUS-BIGNUM ;$4C
- MINUS-BIGNUM ;$4D
- MULTIPLY-BIGNUM ;$4E
- DIVIDE-BIGNUM ;$4F
- LISTIFY-BIGNUM ;$50
- EQUAL-BIGNUM? ;$51
- LESS-THAN-BIGNUM? ;$52
- POSITIVE-BIGNUM? ;$53
- FILE-OPEN-CHANNEL ;$54
- FILE-CLOSE-CHANNEL ;$55
- PRIMITIVE-FASDUMP ;$56
- BINARY-FASLOAD ;$57
- STRING-POSITION ;$58
- STRING-LESS? ;$59
- #F ;$5A
- #F ;$5B
- REHASH ;$5C
- LENGTH ;$5D
- ASSQ ;$5E
- LIST->STRING ;$5F
- EQUAL-STRING-TO-LIST? ;$60
- MAKE-CELL ;$61
- CELL-CONTENTS ;$62
- CELL? ;$63
- CHARACTER-UPCASE ;$64
- CHARACTER-LIST-HASH ;$65
- GCD-FIXNUM ;$66
- COERCE-FIXNUM-TO-BIGNUM ;$67
- COERCE-BIGNUM-TO-FIXNUM ;$68
- PLUS-FLONUM ;$69
- MINUS-FLONUM ;$6A
- MULTIPLY-FLONUM ;$6B
- DIVIDE-FLONUM ;$6C
- EQUAL-FLONUM? ;$6D
- LESS-THAN-FLONUM? ;$6E
- ZERO-BIGNUM? ;$6F
- TRUNCATE-FLONUM ;$70
- ROUND-FLONUM ;$71
- COERCE-INTEGER-TO-FLONUM ;$72
- SINE-FLONUM ;$73
- COSINE-FLONUM ;$74
- ARCTAN-FLONUM ;$75
- EXP-FLONUM ;$76
- LN-FLONUM ;$77
- SQRT-FLONUM ;$78
- PRIMITIVE-FASLOAD ;$79
- GET-FIXED-OBJECTS-VECTOR ;$7A
- SET-FIXED-OBJECTS-VECTOR! ;$7B
- LIST->VECTOR ;$7C
- SUBVECTOR->LIST ;$7D
- PAIR? ;$7E
- NEGATIVE-FIXNUM? ;$7F
- NEGATIVE-BIGNUM? ;$80
- GREATER-THAN-FIXNUM? ;$81
- GREATER-THAN-BIGNUM? ;$82
- STRING-HASH ;$83
- SYSTEM-PAIR-CONS ;$84
- SYSTEM-PAIR? ;$85
- SYSTEM-PAIR-CAR ;$86
- SYSTEM-PAIR-CDR ;$87
- SYSTEM-PAIR-SET-CAR! ;$88
- SYSTEM-PAIR-SET-CDR! ;$89
- #F ;$8A
- #F ;$8B
- SET-CELL-CONTENTS! ;$8C
- &MAKE-OBJECT ;$8D
- SYSTEM-HUNK3-CXR0 ;$8E
- SYSTEM-HUNK3-SET-CXR0! ;$8F
- MAP-MACHINE-ADDRESS-TO-CODE ;$90
- SYSTEM-HUNK3-CXR1 ;$91
- SYSTEM-HUNK3-SET-CXR1! ;$92
- MAP-CODE-TO-MACHINE-ADDRESS ;$93
- SYSTEM-HUNK3-CXR2 ;$94
- SYSTEM-HUNK3-SET-CXR2! ;$95
- PRIMITIVE-PROCEDURE-ARITY ;$96
- SYSTEM-LIST-TO-VECTOR ;$97
- SYSTEM-SUBVECTOR-TO-LIST ;$98
- SYSTEM-VECTOR? ;$99
- SYSTEM-VECTOR-REF ;$9A
- SYSTEM-VECTOR-SET! ;$9B
- WITH-HISTORY-DISABLED ;$9C
- #F ;$9D
- #F ;$9E
- #F ;$9F
- #F ;$A0
- #F ;$A1
- #F ;$A2
- VECTOR-8B-CONS ;$A3
- VECTOR-8B? ;$A4
- VECTOR-8B-REF ;$A5
- VECTOR-8B-SET! ;$A6
- ZERO-FLONUM? ;$A7
- POSITIVE-FLONUM? ;$A8
- NEGATIVE-FLONUM? ;$A9
- GREATER-THAN-FLONUM? ;$AA
- INTERN-CHARACTER-LIST ;$AB
- #F ;$AC
- (STRING-SIZE VECTOR-8B-SIZE) ;$AD
- SYSTEM-VECTOR-SIZE ;$AE
- FORCE ;$AF
- PRIMITIVE-DATUM ;$B0
- MAKE-NON-POINTER-OBJECT ;$B1
- DEBUGGING-PRINTER ;$B2
- STRING-UPCASE ;$B3
- PRIMITIVE-PURIFY ;$B4
- #F ;$B5
- COMPLETE-GARBAGE-COLLECT ;$B6
- DUMP-BAND ;$B7
- SUBSTRING-SEARCH ;$B8
- LOAD-BAND ;$B9
- CONSTANT? ;$BA
- PURE? ;$BB
- PRIMITIVE-GC-TYPE ;$BC
- PRIMITIVE-IMPURIFY ;$BD
- WITH-THREADED-CONTINUATION ;$BE
- WITHIN-CONTROL-POINT ;$BF
- SET-RUN-LIGHT! ;$C0
- FILE-EOF? ;$C1
- FILE-READ-CHAR ;$C2
- FILE-FILL-INPUT-BUFFER ;$C3
- FILE-LENGTH ;$C4
- FILE-WRITE-CHAR ;$C5
- FILE-WRITE-STRING ;$C6
- CLOSE-LOST-OPEN-FILES ;$C7
- #F ;$C8
- WITH-INTERRUPTS-REDUCED ;$C9
- PRIMITIVE-EVAL-STEP ;$CA
- PRIMITIVE-APPLY-STEP ;$CB
- PRIMITIVE-RETURN-STEP ;$CC
- TTY-READ-CHAR-READY? ;$CD
- TTY-READ-CHAR ;$CE
- TTY-READ-CHAR-IMMEDIATE ;$CF
- TTY-READ-FINISH ;$D0
- BIT-STRING-ALLOCATE ;$D1
- MAKE-BIT-STRING ;$D2
- BIT-STRING? ;$D3
- BIT-STRING-LENGTH ;$D4
- BIT-STRING-REF ;$D5
- BIT-SUBSTRING-MOVE-RIGHT! ;$D6
- BIT-STRING-SET! ;$D7
- BIT-STRING-CLEAR! ;$D8
- BIT-STRING-ZERO? ;$D9
- #F ;$DA
- #F ;$DB
- UNSIGNED-INTEGER->BIT-STRING ;$DC
- BIT-STRING->UNSIGNED-INTEGER ;$DD
- #F ;$DE
- READ-BITS! ;$DF
- WRITE-BITS! ;$E0
- MAKE-STATE-SPACE ;$E1
- EXECUTE-AT-NEW-STATE-POINT ;$E2
- TRANSLATE-TO-STATE-POINT ;$E3
- GET-NEXT-CONSTANT ;$E4
- MICROCODE-IDENTIFY ;$E5
- ZERO? ;$E6
- POSITIVE? ;$E7
- NEGATIVE? ;$E8
- &= ;$E9
- &< ;$EA
- &> ;$EB
- &+ ;$EC
- &- ;$ED
- &* ;$EE
- &/ ;$EF
- INTEGER-DIVIDE ;$F0
- 1+ ;$F1
- -1+ ;$F2
- TRUNCATE ;$F3
- ROUND ;$F4
- FLOOR ;$F5
- CEILING ;$F6
- SQRT ;$F7
- EXP ;$F8
- LOG ;$F9
- SIN ;$FA
- COS ;$FB
- &ATAN ;$FC
- TTY-WRITE-CHAR ;$FD
- TTY-WRITE-STRING ;$FE
- TTY-BEEP ;$FF
- TTY-CLEAR ;$100
- GET-EXTERNAL-COUNTS ;$101
- GET-EXTERNAL-NAME ;$102
- GET-EXTERNAL-NUMBER ;$103
- #F ;$104
- #F ;$105
- GET-NEXT-INTERRUPT-CHARACTER ;$106
- CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
- #F ;$108
- SYSTEM-CLOCK ;$109
- FILE-EXISTS? ;$10A
- #F ;$10B
- TTY-MOVE-CURSOR ;$10C
- #F ;$10D
- CURRENT-DATE ;$10E
- CURRENT-TIME ;$10F
- TRANSLATE-FILE ;$110
- COPY-FILE ;$111
- RENAME-FILE ;$112
- REMOVE-FILE ;$113
- LINK-FILE ;$114
- MAKE-DIRECTORY ;$115
- VOLUME-NAME ;$116
- SET-WORKING-DIRECTORY-PATHNAME! ;$117
- OPEN-CATALOG ;$118
- CLOSE-CATALOG ;$119
- NEXT-FILE ;$11A
- CAT-NAME ;$11B
- CAT-KIND ;$11C
- CAT-PSIZE ;$11D
- CAT-LSIZE ;$11E
- CAT-INFO ;$11F
- CAT-BLOCK ;$120
- CAT-CREATE-DATE ;$121
- CAT-CREATE-TIME ;$122
- CAT-LAST-DATE ;$123
- CAT-LAST-TIME ;$124
- ERROR-MESSAGE ;$125
- CURRENT-YEAR ;$126
- CURRENT-MONTH ;$127
- CURRENT-DAY ;$128
- CURRENT-HOUR ;$129
- CURRENT-MINUTE ;$12A
- CURRENT-SECOND ;$12B
- INIT-FLOPPY ;$12C
- ZERO-FLOPPY ;$12D
- PACK-VOLUME ;$12E
- LOAD-PICTURE ;$12F
- STORE-PICTURE ;$130
- LOOKUP-SYSTEM-SYMBOL ;$131
- #F ;$132
- #F ;$133
- CLEAR-TO-END-OF-LINE ;$134
- #F ;$135
- #F ;$136
- WITH-INTERRUPT-MASK ;$137
- STRING? ;$138
- STRING-LENGTH ;$139
- STRING-REF ;$13A
- STRING-SET! ;$13B
- SUBSTRING-MOVE-RIGHT! ;$13C
- SUBSTRING-MOVE-LEFT! ;$13D
- STRING-ALLOCATE ;$13E
- STRING-MAXIMUM-LENGTH ;$13F
- SET-STRING-LENGTH! ;$140
- VECTOR-8B-FILL! ;$141
- VECTOR-8B-FIND-NEXT-CHAR ;$142
- VECTOR-8B-FIND-PREVIOUS-CHAR ;$143
- VECTOR-8B-FIND-NEXT-CHAR-CI ;$144
- VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145
- SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146
- SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147
- SUBSTRING=? ;$148
- SUBSTRING-CI=? ;$149
- SUBSTRING<? ;$14A
- SUBSTRING-UPCASE! ;$14B
- SUBSTRING-DOWNCASE! ;$14C
- SUBSTRING-MATCH-FORWARD ;$14D
- SUBSTRING-MATCH-BACKWARD ;$14E
- SUBSTRING-MATCH-FORWARD-CI ;$14F
- SUBSTRING-MATCH-BACKWARD-CI ;$150
- PHOTO-OPEN ;$151
- PHOTO-CLOSE ;$152
- SETUP-TIMER-INTERRUPT ;$153
- #F ;$154
- #F ;$155
- #F ;$156
- #F ;$157
- #F ;$158
- #F ;$159
- #F ;$15A
- #F ;$15B
- #F ;$15C
- #F ;$15D
- #F ;$15E
- #F ;$15F
- #F ;$160
- EXTRACT-NON-MARKED-VECTOR ;$161
- UNSNAP-LINKS! ;$162
- SAFE-PRIMITIVE? ;$163
- SUBSTRING-READ ;$164
- SUBSTRING-WRITE ;$165
- SCREEN-X-SIZE ;$166
- SCREEN-Y-SIZE ;$167
- SCREEN-WRITE-CURSOR ;$168
- SCREEN-WRITE-CHARACTER ;$169
- SCREEN-WRITE-SUBSTRING ;$16A
- NEXT-FILE-MATCHING ;$16B
- #F ;$16C
- TTY-WRITE-BYTE ;$16D
- FILE-READ-BYTE ;$16E
- FILE-WRITE-BYTE ;$16F
- #F #| SAVE-SCREEN |# ;$170
- #F #| RESTORE-SCREEN! |# ;$171
- #F #| SUBSCREEN-CLEAR! |# ;$172
- #F #| &GCD |# ;$173
- #F #| TTY-REDRAW-SCREEN |# ;$174
- #F #| SCREEN-INVERSE-VIDEO! |# ;$175
- STRING->SYNTAX-ENTRY ;$176
- SCAN-WORD-FORWARD ;$177
- SCAN-WORD-BACKWARD ;$178
- SCAN-LIST-FORWARD ;$179
- SCAN-LIST-BACKWARD ;$17A
- SCAN-SEXPS-FORWARD ;$17B
- SCAN-FORWARD-TO-WORD ;$17C
- SCAN-BACKWARD-PREFIX-CHARS ;$17D
- CHAR->SYNTAX-CODE ;$17E
- QUOTED-CHAR? ;$17F
- MICROCODE-TABLES-FILENAME ;$180
- #F ;$181
- #F #| FIND-PASCAL-PROGRAM |# ;$182
- #F #| EXECUTE-PASCAL-PROGRAM |# ;$183
- #F #| GRAPHICS-MOVE |# ;$184
- #F #| GRAPHICS-LINE |# ;$185
- #F #| GRAPHICS-PIXEL |# ;$186
- #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187
- #F #| ALPHA-RASTER? |# ;$188
- #F #| TOGGLE-ALPHA-RASTER |# ;$189
- #F #| GRAPHICS-RASTER? |# ;$18A
- #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B
- #F #| GRAPHICS-CLEAR |# ;$18C
- #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D
- ERROR-PROCEDURE ;$18E
- VOLUME-EXISTS? ;$18F
- RE-CHAR-SET-ADJOIN! ;$190
- RE-COMPILE-FASTMAP ;$191
- RE-MATCH ;$192
- RE-SEARCH-FORWARD ;$193
- RE-SEARCH-BACKWARD ;$194
- (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
- (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
- BIT-STRING-FILL! ;$197
- BIT-STRING-MOVE! ;$198
- BIT-STRING-MOVEC! ;$199
- BIT-STRING-OR! ;$19A
- BIT-STRING-AND! ;$19B
- BIT-STRING-ANDC! ;$19C
- BIT-STRING=? ;$19D
- WORKING-DIRECTORY-PATHNAME ;$19E
- OPEN-DIRECTORY ;$19F
- DIRECTORY-READ ;$1A0
- UNDER-EMACS? ;$1A1
- TTY-FLUSH-OUTPUT ;$1A2
- RELOAD-BAND-NAME ;$1A3
- ))
-\f
-;;; [] External
-
-(vector-set! (get-fixed-objects-vector)
- 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES)
- #())
-\f
-;;; [] Errors
-
-(vector-set! (get-fixed-objects-vector)
- 7 ;(fixed-objects-vector-slot 'MICROCODE-ERRORS-VECTOR)
- #(BAD-ERROR-CODE ;00
- UNBOUND-VARIABLE ;01
- UNASSIGNED-VARIABLE ;02
- UNDEFINED-PROCEDURE ;03
- #F ;04
- #F ;05
- BAD-FRAME ;06
- BROKEN-CVARIABLE ;07
- UNDEFINED-USER-TYPE ;08
- UNDEFINED-PRIMITIVE-OPERATION ;09
- EXTERNAL-RETURN ;0A
- EXECUTE-MANIFEST-VECTOR ;0B
- WRONG-NUMBER-OF-ARGUMENTS ;0C
- WRONG-TYPE-ARGUMENT-0 ;0D
- WRONG-TYPE-ARGUMENT-1 ;0E
- WRONG-TYPE-ARGUMENT-2 ;0F
- BAD-RANGE-ARGUMENT-0 ;10
- BAD-RANGE-ARGUMENT-1 ;11
- BAD-RANGE-ARGUMENT-2 ;12
- #F ;13
- #F ;14
- BAD-INTERRUPT-CODE ;15
- #F ;16
- FASL-FILE-TOO-BIG ;17
- FASL-FILE-BAD-DATA ;18
- IMPURIFY-OBJECT-TOO-LARGE ;19
- WRITE-INTO-PURE-SPACE ;1A
- #F ;1B
- #F ;1C
- #F ;1D
- FAILED-ARG-1-COERCION ;1E
- FAILED-ARG-2-COERCION ;1F
- OUT-OF-FILE-HANDLES ;20
- #F ;21
- BAD-RANGE-ARGUMENT-3 ;22
- BAD-RANGE-ARGUMENT-4 ;23
- BAD-RANGE-ARGUMENT-5 ;24
- BAD-RANGE-ARGUMENT-6 ;25
- BAD-RANGE-ARGUMENT-7 ;26
- BAD-RANGE-ARGUMENT-8 ;27
- BAD-RANGE-ARGUMENT-9 ;28
- WRONG-TYPE-ARGUMENT-3 ;29
- WRONG-TYPE-ARGUMENT-4 ;2A
- WRONG-TYPE-ARGUMENT-5 ;2B
- WRONG-TYPE-ARGUMENT-6 ;2C
- WRONG-TYPE-ARGUMENT-7 ;2D
- WRONG-TYPE-ARGUMENT-8 ;2E
- WRONG-TYPE-ARGUMENT-9 ;2F
- INAPPLICABLE-CONTINUATION ;30
- COMPILED-CODE-ERROR ;31
- FLOATING-OVERFLOW ;32
- UNIMPLEMENTED-PRIMITIVE ;33
- ))
-\f
-;;; [] Terminations
-
-(vector-set! (get-fixed-objects-vector)
- 22 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATIONS-VECTOR)
- #(HALT ;00
- DISK-RESTORE ;01
- BROKEN-HEART ;02
- NON-POINTER-RELOCATION ;03
- BAD-ROOT ;04
- NON-EXISTENT-CONTINUATION ;05
- BAD-STACK ;06
- STACK-OVERFLOW ;07
- STACK-ALLOCATION-FAILED ;08
- NO-ERROR-HANDLER ;09
- NO-INTERRUPT-HANDLER ;0A
- UNIMPLEMENTED-CONTINUATION ;0B
- EXIT ;0C
- BAD-PRIMITIVE-DURING-ERROR ;0D
- EOF ;0E
- BAD-PRIMITIVE ;0F
- TERMINATION-HANDLER ;10
- END-OF-CONTINUATION ;11
- INVALID-TYPE-CODE ;12
- COMPILER-DEATH ;13
- GC-OUT-OF-SPACE ;14
- ))
-
-(vector-set! (get-fixed-objects-vector)
- 23 ;(fixed-objects-vector-slot 'MICROCODE-TERMINATION-PROCEDURES)
- #())
-\f
-;;; [] Identification
-
-(vector-set! (get-fixed-objects-vector)
- 8 ;(fixed-objects-vector-slot 'MICROCODE-IDENTIFICATION-VECTOR)
- #(SYSTEM-RELEASE-STRING ;00
- MICROCODE-VERSION ;01
- MICROCODE-MODIFICATION ;02
- CONSOLE-WIDTH ;03
- CONSOLE-HEIGHT ;04
- NEWLINE-CHAR ;05
- FLONUM-MANTISSA-LENGTH ;06
- FLONUM-EXPONENT-LENGTH ;07
- OS-NAME-STRING ;08
- OS-VARIANT-STRING ;09
- ))
-
-;;; This identification string is saved by the system.
-
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $"
+++ /dev/null
-/* -*-C-*-
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. */
-
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.41 1987/04/17 04:03:23 cph Exp $
-
-This file contains version information for the microcode. */
-\f
-/* Scheme system release version */
-
-#ifndef RELEASE
-#define RELEASE "5.0.20"
-#endif
-
-/* Microcode release version */
-
-#ifndef VERSION
-#define VERSION 9
-#endif
-#ifndef SUBVERSION
-#define SUBVERSION 41
-#endif
-
-#ifndef UCODE_TABLES_FILENAME
-#define UCODE_TABLES_FILENAME "utabmd.bin"
-#endif
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/make.scm,v 3.4 1987/03/20 23:50:32 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: System Construction
-
-(in-package system-global-environment
-(declare (usual-integrations))
-\f
-(define sf)
-(define sf/set-file-syntax-table!)
-(define sf/add-file-declarations!)
-(load "$zcomp/base/load" system-global-environment)
-
-(load-system system-global-environment
- 'PACKAGE/SCODE-OPTIMIZER
- '(SYSTEM-GLOBAL-ENVIRONMENT)
- '(
- (PACKAGE/SCODE-OPTIMIZER
- "mvalue" ;Multiple Value Support
- "eqsets" ;Set Data Abstraction
-
- "object" ;Data Structures
- "emodel" ;Environment Model
- "gconst" ;Global Primitives List
- "usicon" ;Usual Integrations: Constants
- "tables" ;Table Abstractions
- "packag" ;Global packaging
- )
-
- (PACKAGE/TOP-LEVEL
- "toplev" ;Top Level
- )
-
- (PACKAGE/TRANSFORM
- "xform" ;SCode -> Internal
- )
-
- (PACKAGE/INTEGRATE
- "subst" ;Beta Substitution Optimizer
- )
-
- (PACKAGE/CGEN
- "cgen" ;Internal -> SCode
- )
-
- (PACKAGE/EXPANSION
- "usiexp" ;Usual Integrations: Expanders
- )
-
- (PACKAGE/DECLARATIONS
- "pardec" ;Declaration Parser
- )
-
- (PACKAGE/COPY
- "copy" ;Copy Expressions
- )
-
- (PACKAGE/FREE
- "free" ;Free Variable Analysis
- )
-
- (PACKAGE/SAFE?
- "safep" ;Safety Analysis
- )
-
- (PACKAGE/CHANGE-TYPE
- "chtype" ;Type interning
- )
-
- ))
-\f
-(in-package package/scode-optimizer
- (define integrations
- "$zcomp/source/object")
-
- (define scode-optimizer/system
- (make-environment
- (define :name "SF")
- (define :version 3)
- (define :modification 3)))
-
- (add-system! scode-optimizer/system)
-
- (scode-optimizer/initialize!))
-
-;;; end IN-PACKAGE SYSTEM-GLOBAL-ENVIRONMENT
-)
\ No newline at end of file
+++ /dev/null
-#| -*-Scheme-*-
-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/sf/toplev.scm,v 3.2 1987/03/19 17:23:08 cph Exp $
-
-Copyright (c) 1987 Massachusetts Institute of Technology
-
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
-
-1. Any copy made of this software must include this copyright notice
-in full.
-
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
-
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
-
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; SCode Optimizer: Top Level
-
-(declare (usual-integrations))
-\f
-;;;; User Interface
-
-(define generate-unfasl-files? false
- "Set this non-false to cause unfasl files to be generated by default.")
-
-(define optimize-open-blocks? false
- "Set this non-false to eliminate unreferenced auxiliary definitions.
-Currently this optimization is not implemented.")
-
-(define (integrate/procedure procedure declarations)
- (if (compound-procedure? procedure)
- (procedure-components procedure
- (lambda (*lambda environment)
- (scode-eval (integrate/scode *lambda declarations false)
- environment)))
- (error "INTEGRATE/PROCEDURE: Not a compound procedure" procedure)))
-
-(define (integrate/sexp s-expression syntax-table declarations receiver)
- (integrate/simple (lambda (s-expressions)
- (phase:syntax s-expressions syntax-table))
- (list s-expression) declarations receiver))
-
-(define (integrate/scode scode declarations receiver)
- (integrate/simple identity-procedure scode declarations receiver))
-
-(define (sf input-string #!optional bin-string spec-string)
- (if (unassigned? bin-string) (set! bin-string false))
- (if (unassigned? spec-string) (set! spec-string false))
- (syntax-file input-string bin-string spec-string))
-
-(define (scold input-string #!optional bin-string spec-string)
- "Use this only for syntaxing the cold-load root file.
-Currently only the 68000 implementation needs this."
- (if (unassigned? bin-string) (set! bin-string false))
- (if (unassigned? spec-string) (set! spec-string false))
- (fluid-let ((wrapping-hook wrap-with-control-point))
- (syntax-file input-string bin-string spec-string)))
-\f
-(define (sf/set-file-syntax-table! pathname syntax-table)
- (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
- (let ((association (find-file-info/assoc pathname)))
- (if association
- (set-cdr! association
- (transmit-values (cdr association)
- (lambda (ignore declarations)
- (return-2 syntax-table declarations))))
- (set! file-info
- (cons (cons pathname (return-2 syntax-table '()))
- file-info))))))
-
-(define (sf/add-file-declarations! pathname declarations)
- (let ((pathname (pathname->absolute-pathname (->pathname pathname))))
- (let ((association (find-file-info/assoc pathname)))
- (if association
- (set-cdr! association
- (transmit-values (cdr association)
- (lambda (syntax-table declarations*)
- (return-2 syntax-table
- (append! declarations*
- (list-copy declarations))))))
- (set! file-info
- (cons (cons pathname (return-2 false declarations))
- file-info))))))
-
-(define file-info
- '())
-
-(define (find-file-info pathname)
- (let ((association
- (find-file-info/assoc (pathname->absolute-pathname pathname))))
- (if association
- (cdr association)
- (return-2 false '()))))
-
-(define (find-file-info/assoc pathname)
- (list-search-positive file-info
- (lambda (entry)
- (pathname=? (car entry) pathname))))
-
-(define (pathname=? x y)
- (and (equal? (pathname-device x) (pathname-device y))
- (equal? (pathname-directory x) (pathname-directory y))
- (equal? (pathname-name x) (pathname-name y))))
-\f
-;;;; File Syntaxer
-
-(define sf/default-input-pathname
- (make-pathname false false false "scm" 'NEWEST))
-
-(define sf/default-externs-pathname
- (make-pathname false false false "ext" 'NEWEST))
-
-(define sf/output-pathname-type "bin")
-(define sf/unfasl-pathname-type "unf")
-
-(define (syntax-file input-string bin-string spec-string)
- (let ((eval-sf-expression
- (lambda (input-string)
- (let ((input-path
- (pathname->input-truename
- (merge-pathnames (->pathname input-string)
- sf/default-input-pathname))))
- (if (not input-path)
- (error "SF: File does not exist" input-string))
- (let ((bin-path
- (let ((bin-path
- (pathname-new-type input-path
- sf/output-pathname-type)))
- (if bin-string
- (merge-pathnames (->pathname bin-string) bin-path)
- bin-path))))
- (let ((spec-path
- (and (or spec-string generate-unfasl-files?)
- (let ((spec-path
- (pathname-new-type bin-path
- sf/unfasl-pathname-type)))
- (if spec-string
- (merge-pathnames (->pathname spec-string)
- spec-path)
- spec-path)))))
- (syntax-file* input-path bin-path spec-path)))))))
- (if (list? input-string)
- (for-each (lambda (input-string)
- (eval-sf-expression input-string))
- input-string)
- (eval-sf-expression input-string)))
- *the-non-printing-object*)
-\f
-(define (syntax-file* input-pathname bin-pathname spec-pathname)
- (let ((start-date (date))
- (start-time (time))
- (input-filename (pathname->string input-pathname))
- (bin-filename (pathname->string bin-pathname))
- (spec-filename (and spec-pathname (pathname->string spec-pathname))))
- (newline)
- (write-string "Syntax file: ")
- (write input-filename)
- (write-string " ")
- (write bin-filename)
- (write-string " ")
- (write spec-filename)
- (transmit-values
- (transmit-values (find-file-info input-pathname)
- (lambda (syntax-table declarations)
- (integrate/file input-pathname syntax-table declarations
- spec-pathname)))
- (lambda (expression externs events)
- (fasdump (wrapping-hook
- (make-comment `((SOURCE-FILE . ,input-filename)
- (DATE . ,start-date)
- (TIME . ,start-time)
- (FLUID-LET . ,*fluid-let-type*))
- (set! expression false)))
- bin-pathname)
- (write-externs-file (pathname-new-type
- bin-pathname
- (pathname-type sf/default-externs-pathname))
- (set! externs false))
- (if spec-pathname
- (begin (newline)
- (write-string "Writing ")
- (write spec-filename)
- (with-output-to-file spec-pathname
- (lambda ()
- (newline)
- (write `(DATE ,start-date ,start-time))
- (newline)
- (write `(FLUID-LET ,*fluid-let-type*))
- (newline)
- (write `(SOURCE-FILE ,input-filename))
- (newline)
- (write `(BINARY-FILE ,bin-filename))
- (for-each (lambda (event)
- (newline)
- (write `(,(car event)
- (RUNTIME ,(cdr event)))))
- events)))
- (write-string " -- done")))))))
-\f
-(define (read-externs-file pathname)
- (let ((pathname
- (merge-pathnames (->pathname pathname) sf/default-externs-pathname)))
- (if (file-exists? pathname)
- (fasload pathname)
- (begin (warn "Nonexistent externs file" (pathname->string pathname))
- '()))))
-
-(define (write-externs-file pathname externs)
- (cond ((not (null? externs))
- (fasdump externs pathname))
- ((file-exists? pathname)
- (delete-file pathname))))
-
-(define (print-spec identifier names)
- (newline)
- (newline)
- (write-string "(")
- (write identifier)
- (let loop
- ((names
- (sort names
- (lambda (x y)
- (string<? (symbol->string x)
- (symbol->string y))))))
- (if (not (null? names))
- (begin (newline)
- (write (car names))
- (loop (cdr names)))))
- (write-string ")"))
-
-(define (wrapping-hook scode)
- scode)
-
-(define control-point-tail
- `(3 ,(primitive-set-type (microcode-type 'NULL) (* 4 4))
- () () () () () () () () () () () () () () ()))
-
-(define (wrap-with-control-point scode)
- (system-list-to-vector type-code-control-point
- `(,return-address-restart-execution
- ,scode
- ,system-global-environment
- ,return-address-non-existent-continuation
- ,@control-point-tail)))
-
-(define type-code-control-point
- (microcode-type 'CONTROL-POINT))
-
-(define return-address-restart-execution
- (make-return-address (microcode-return 'RESTART-EXECUTION)))
-
-(define return-address-non-existent-continuation
- (make-return-address (microcode-return 'NON-EXISTENT-CONTINUATION)))
-\f
-;;;; Optimizer Top Level
-
-(define (integrate/file file-name syntax-table declarations compute-free?)
- (integrate/kernel (lambda ()
- (phase:syntax (phase:read file-name) syntax-table))
- declarations))
-
-(define (integrate/simple preprocessor input declarations receiver)
- (transmit-values
- (integrate/kernel (lambda () (preprocessor input)) declarations)
- (or receiver
- (lambda (expression externs events)
- expression))))
-
-(define (integrate/kernel get-scode declarations)
- (fluid-let ((previous-time false)
- (previous-name false)
- (events '()))
- (transmit-values
- (transmit-values
- (transmit-values
- (phase:transform (canonicalize-scode (get-scode) declarations))
- phase:optimize)
- phase:generate-scode)
- (lambda (externs expression)
- (end-phase)
- (return-3 expression externs (reverse! events))))))
-
-(define (canonicalize-scode scode declarations)
- (let ((declarations
- ((access process-declarations syntaxer-package) declarations)))
- (if (null? declarations)
- scode
- (scan-defines (make-sequence
- (list (make-block-declaration declarations)
- scode))
- make-open-block))))
-\f
-(define (phase:read filename)
- (mark-phase "Read")
- (read-file filename))
-
-(define (phase:syntax s-expression #!optional syntax-table)
- (if (or (unassigned? syntax-table) (not syntax-table))
- (set! syntax-table (make-syntax-table system-global-syntax-table)))
- (mark-phase "Syntax")
- (syntax* s-expression syntax-table))
-
-(define (phase:transform scode)
- (mark-phase "Transform")
- (transform/expression scode))
-
-(define (phase:optimize block expression)
- (mark-phase "Optimize")
- (integrate/expression block expression))
-
-(define (phase:generate-scode operations environment expression)
- (mark-phase "Generate SCode")
- (return-2 (operations->external operations environment)
- (cgen/expression expression)))
-
-(define previous-time)
-(define previous-name)
-(define events)
-
-(define (mark-phase this-name)
- (end-phase)
- (newline)
- (write-string " ")
- (write-string this-name)
- (write-string "...")
- (set! previous-name this-name))
-
-(define (end-phase)
- (let ((this-time (runtime)))
- (if previous-time
- (let ((dt (- this-time previous-time)))
- (set! events (cons (cons previous-name dt) events))
- (newline)
- (write-string " Time: ")
- (write dt)
- (write-string " seconds.")))
- (set! previous-time this-time)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff