home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
s
/
s48.zip
/
FILES.SCM
< prev
next >
Wrap
Text File
|
1992-07-06
|
9KB
|
344 lines
; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Files comprising the system.
; Load this file into the Scheme48 user environment.
;
; With minor modifications, it can be loaded into Pseudoscheme or T;
; simply change the file prefix "s48-" to "p-" or "t-" in the definitions
; of prescheme-files and features-files.
; Load a linker by saying
; (load-linker) ; in Scheme
;
; After the linker is loaded, link a system by saying
; (link-system)
; If the current directory isn't the scheme48 root directory, you
; should set *scheme48-file-prefix* to that directory, e.g.
; (set! *scheme48-file-prefix* "~/s48/").
(define *scheme48-file-prefix* "")
; For T, set *default-default-file-type* to the object file type for your
; particular operating system (e.g. 'so for SPARC object file), or to
; #f to let T do the defaulting. (T may not be capable of defaulting
; properly, depending on which bugs your implementation has, and whether
; it gets passed "namelists" or strings.)
(define *default-default-file-type* 'scm)
; You might choose to redefine the procedures load-file and/or no-value
; for Pseudoscheme or T as well.
(define (load-file namelist)
(load (namestring namelist)))
(define (no-value)
(if '#f '#f))
(define features-files
'((boot s48-record) ;or p-record, t-record, record
(boot s48-features) ;or p-features, t-features
(boot util)
(rts table)
))
; Runtime system files
; Base-files as a whole has the following properties:
; - it supports all of R^4 Report Scheme other than LOAD and non-fixnum
; arithmetic
; - it has no free variables
; - it has a minimal error system
(define arch-files
'((rts defenum scm)
(rts arch)
(rts rtsistruct) ; ?
))
(define base-files
'((rts base)
(rts util)
(rts generic)
(rts number) ; needs generic
(rts dynamic)
(rts port) ; needs dynamic(make-fluid)
(rts record) ; needs generic
(rts table) ; needs record
(rts wind) ; Dynamic-wind (optional)
(rts condition) ; needs write, generic, arch
(rts xprim) ;For n-ary primitives. Optional.
))
(define rts-files-1 ;The base/rts-1 split is an artifact of the mobot system
'((rts write) ;Needs port, generic(disclose), number(number->string)
(rts read)
(rts lize) ;The rationalize procedure (optional, but if unsupplied,
; change reflect.scm to not export it).
))
(define compiler-files-1
'((rts enum)
(rts package)
(rts cenv)
(rts segment)
(rts comp)
(rts cprim)
(rts derive)
(rts syntax-rules)
(rts ctop)
))
(define rts-files-2
'((rts shadow) ;Exception handler to support package system
(rts reflect) ;Create the Scheme package and define LOAD
(rts bare) ;Bare-bones startup loop
))
(define rts-files
(append arch-files
base-files
rts-files-1
compiler-files-1
rts-files-2))
(define system-image-file
'(boot system image))
; Linker files
(define build-files
'((boot build)
(misc debuginfo)))
(define boot-files
'((boot data)
(boot transport)
(boot write-image)
))
(define compiler-files
(append features-files
arch-files
compiler-files-1))
(define linker-files
(append boot-files
;; Can replace boot-files by '((boot s48-write-image))
;; when the image level doesn't change
build-files))
(define quickly-files
(append '((boot import-comp) ; replaces compiler-files
(boot s48-write-image)) ; replaces boot-files
build-files))
; VM files
(define vm-files
'(
(rts defenum)
(vm s48-prescheme)
(vm util)
(vm macros)
(vm memory)
(vm data)
(vm struct)
(vm vmio)
(vm init)
(vm gc)
(vm arch)
(vm istruct)
(vm stack)
(vm interp)
(vm prim)
(vm resume)
))
(define vm-debug-files
'(
(vm s48-debug)
(vm transport)
(vm debug)
))
; The extra-files define optional features that are loaded after
; startup. The system is pretty useless without the first 5 of these
; (command through debuginfo).
(define extra-files
'((misc command) ;Command processor
(rts defenum) ; (arch.scm needs)
(rts arch) ; (disclosers.scm needs)
(misc disclosers) ;Make error messages be more informative
(misc debuginfo) ;Defines read-debug-info
(misc debug) ;Debugging commands: trace, preview, etc.
(misc inspect) ;Data structure inspector
(misc disasm) ;Disassembler
(misc pack) ;Package system support
(rts xnum) ;Support for extended numbers
(rts bignum) ;Bignum arithmetic - slow but faithful
(rts ratnum) ;Rationals
(rts recnum) ;Complex numbers (such as they are)
))
(define thread-files
'((misc queue) ;FIFO queues
(misc compose-cont) ;Subprimitive used by threads implementation
(misc thread) ;Multitasking
(misc sleep) ;Multitasking
))
(define misc-files
'(
(boot p-features) ;Can replace s48-features.scm
(boot t-features) ;Can replace s48-features.scm
(boot p-record) ;Can replace s48-record.scm
(boot t-record) ;Can replace s48-record.scm
(boot record) ;Can replace s48-record.scm
(boot testsys) ;For making a tiny image that says hello
(boot little) ;For making a tiny read-eval-print loop
(boot package-defs) ;Package setup for for-debugging.scm
(boot for-debugging) ;For debugging new runtime systems
(misc package-defs) ;Package setup for things in misc directory
(misc assem) ;An assembler
(misc sort) ;Online merge sort, thanks to Bob Nix and T project
(misc random) ;Random number generator, thanks to T project
(misc pp) ;Pretty-printer (internally ugly)
(misc sicp) ;Structure & Interpretation compatibility
(misc tokenize) ;Read tables (used by pratt.scm)
(misc pratt) ;Pratt parser (infix), thanks to Paradigm
(misc sgol) ;Sample use of Pratt parser
(misc sgol-runtime) ;Goes with sgol
(misc icon) ;backtracking example
(misc wind-test) ;Just a test for dynamic-wind
(misc traverse) ;Storage leak debugger
;; Richard's stuff
(boot byte-code-test)
(misc bigbit) ;Bignum bitwise operators
(misc defrecord)
(misc xport) ;Extended port framework
(misc new-ports)
(misc format)
(misc values) ;Multiple values
(vm load)
(vm debug-util)
(vm heap-stack)
))
; Script: load the Scheme48 linker.
(define (load-linker)
(load-compiler)
(for-each load-file linker-files)
(no-value))
(define (load-compiler) ;load compiler only
(for-each load-file compiler-files)
(no-value))
; Script: link a Scheme48 system image.
(define (link-system)
(set! *the-system* #f) ;free up space for GC
(set! *the-system*
(make-system (map (lambda (n) (namestring n 'scm))
rts-files)
'(usual-resumer bare)
'#t))
(write-system *the-system* (namestring system-image-file))
(write-debug-info (namestring '(boot system debug)))
(no-value))
(define *the-system* #f)
(define (link-little)
(set! *the-system*
(make-system (map (lambda (n) (namestring n 'scm))
(append arch-files
base-files
rts-files-1
'((boot little))))
'(usual-resumer little)
'#t))
(write-system *the-system* (namestring '(boot little image))))
; Convert a namelist '(foo bar) into a string "foo/bar.scm"
; This is Unix-specific, unfortunately. I guess that's unavoidable.
(define (namestring namelist . maybe-default-type)
(let* ((default-type (if (null? maybe-default-type)
*default-default-file-type*
(car maybe-default-type)))
(type (if (null? (cddr namelist))
default-type
(caddr namelist))))
(string-append *scheme48-file-prefix*
(namestring-component (car namelist))
"/"
(namestring-component (cadr namelist))
(if type
(string-append "."
(namestring-component type))
""))))
(define (namestring-component x)
(cond ((string? x) x)
((symbol? x)
(list->string (map char-downcase
(string->list (symbol->string x)))))
(else (error "bogus namelist component" x))))
; (write-makefile "~/s48/Makefile.filenames")
; or % make Makefile.filenames
(define (write-makefile target)
(set! *scheme48-file-prefix* "") ;?
(call-with-output-file target
(lambda (port)
(display "#### Do not edit this file. Edit files.scm instead. ####"
port)
(newline port)
(newline port)
(let* ((all-files '())
(foo (lambda (var files)
(display var port)
(display " = " port)
(for-each (lambda (file)
(if (not (member file all-files))
(set! all-files (cons file all-files)))
(display (namestring file 'scm) port)
(display " " port))
files)
(newline port))))
(foo "SYSTEM_IMAGE" (list system-image-file))
;; The following is a kludge to prevent boot/system.image from going
;; into the distribution.
(set! all-files '())
(foo "RTSFILES" rts-files)
(foo "COMPILERFILES" compiler-files)
(foo "LINKERFILES" linker-files)
(foo "QUICKLYFILES" quickly-files)
(foo "EXTRAFILES" extra-files)
(foo "OTHERFILES" (append vm-files
vm-debug-files
thread-files
misc-files))
(foo "ALLFILES" (reverse all-files))))))