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 >
Text File  |  1992-07-06  |  9KB  |  344 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Files comprising the system.
  4. ; Load this file into the Scheme48 user environment.
  5. ;
  6. ; With minor modifications, it can be loaded into Pseudoscheme or T;
  7. ; simply change the file prefix "s48-" to "p-" or "t-" in the definitions
  8. ; of prescheme-files and features-files.
  9.  
  10. ; Load a linker by saying
  11. ;   (load-linker)    ; in Scheme
  12. ; 
  13. ; After the linker is loaded, link a system by saying
  14. ;   (link-system)
  15.  
  16.  
  17. ; If the current directory isn't the scheme48 root directory, you
  18. ; should set *scheme48-file-prefix* to that directory, e.g.
  19. ;   (set! *scheme48-file-prefix* "~/s48/").
  20.  
  21. (define *scheme48-file-prefix* "")
  22.  
  23. ; For T, set *default-default-file-type* to the object file type for your
  24. ; particular operating system (e.g. 'so for SPARC object file), or to
  25. ; #f to let T do the defaulting.  (T may not be capable of defaulting
  26. ; properly, depending on which bugs your implementation has, and whether
  27. ; it gets passed "namelists" or strings.)
  28.  
  29. (define *default-default-file-type* 'scm)
  30.  
  31. ; You might choose to redefine the procedures load-file and/or no-value
  32. ; for Pseudoscheme or T as well.
  33.  
  34. (define (load-file namelist)
  35.   (load (namestring namelist)))
  36.  
  37. (define (no-value)
  38.   (if '#f '#f))
  39.  
  40. (define features-files
  41.   '((boot s48-record)     ;or p-record, t-record, record
  42.     (boot s48-features)   ;or p-features, t-features
  43.     (boot util)
  44.     (rts table)
  45.     ))
  46.  
  47.  
  48. ; Runtime system files
  49.  
  50. ; Base-files as a whole has the following properties:
  51. ;   - it supports all of R^4 Report Scheme other than LOAD and non-fixnum
  52. ;     arithmetic
  53. ;   - it has no free variables
  54. ;   - it has a minimal error system
  55.  
  56. (define arch-files
  57.   '((rts defenum scm)
  58.     (rts arch)
  59.     (rts rtsistruct) ; ?
  60.     ))
  61.  
  62. (define base-files
  63.   '((rts base)
  64.     (rts util)
  65.     (rts generic)
  66.     (rts number)     ; needs generic
  67.     (rts dynamic)
  68.     (rts port)       ; needs dynamic(make-fluid)
  69.     (rts record)     ; needs generic
  70.     (rts table)         ; needs record
  71.     (rts wind)         ; Dynamic-wind (optional)
  72.     (rts condition)  ; needs write, generic, arch
  73.     (rts xprim)         ;For n-ary primitives.  Optional.
  74.     ))
  75.  
  76. (define rts-files-1  ;The base/rts-1 split is an artifact of the mobot system
  77.   '((rts write)         ;Needs port, generic(disclose), number(number->string)
  78.     (rts read)
  79.     (rts lize)       ;The rationalize procedure (optional, but if unsupplied,
  80.              ; change reflect.scm to not export it).
  81.     ))
  82.  
  83. (define compiler-files-1
  84.   '((rts enum)
  85.     (rts package)
  86.     (rts cenv)
  87.     (rts segment)
  88.     (rts comp)
  89.     (rts cprim)
  90.     (rts derive)
  91.     (rts syntax-rules)
  92.     (rts ctop)
  93.     ))
  94.  
  95. (define rts-files-2
  96.   '((rts shadow)     ;Exception handler to support package system
  97.     (rts reflect)    ;Create the Scheme package and define LOAD
  98.     (rts bare)       ;Bare-bones startup loop
  99.     ))
  100.  
  101. (define rts-files
  102.   (append arch-files
  103.       base-files
  104.       rts-files-1
  105.       compiler-files-1
  106.       rts-files-2))
  107.  
  108. (define system-image-file
  109.   '(boot system image))
  110.  
  111. ; Linker files
  112.  
  113. (define build-files
  114.   '((boot build)
  115.     (misc debuginfo)))
  116.  
  117. (define boot-files
  118.   '((boot data)
  119.     (boot transport)
  120.     (boot write-image)
  121.    ))
  122.  
  123. (define compiler-files
  124.   (append features-files
  125.       arch-files
  126.       compiler-files-1))
  127.  
  128. (define linker-files
  129.   (append boot-files
  130.       ;; Can replace boot-files by '((boot s48-write-image))
  131.       ;; when the image level doesn't change
  132.       build-files))
  133.  
  134. (define quickly-files
  135.   (append '((boot import-comp)        ; replaces compiler-files
  136.             (boot s48-write-image))   ; replaces boot-files
  137.       build-files))
  138.  
  139. ; VM files
  140.  
  141. (define vm-files
  142.   '(
  143.     (rts defenum)
  144.     (vm s48-prescheme)
  145.     (vm util)
  146.     (vm macros)
  147.     
  148.     (vm memory)
  149.     (vm data)
  150.     (vm struct)
  151.     (vm vmio)
  152.     (vm init)
  153.     (vm gc)
  154.  
  155.     (vm arch)
  156.     (vm istruct)
  157.     (vm stack)
  158.     (vm interp)
  159.     (vm prim)
  160.  
  161.     (vm resume)
  162.     ))
  163.  
  164. (define vm-debug-files
  165.   '(
  166.     (vm s48-debug)
  167.     (vm transport)
  168.     (vm debug)
  169.     ))
  170.  
  171. ; The extra-files define optional features that are loaded after
  172. ; startup.  The system is pretty useless without the first 5 of these
  173. ; (command through debuginfo).
  174.  
  175. (define extra-files
  176.   '((misc command)      ;Command processor
  177.  
  178.     (rts defenum)       ; (arch.scm needs)
  179.     (rts arch)        ; (disclosers.scm needs)
  180.     (misc disclosers)   ;Make error messages be more informative
  181.     (misc debuginfo)    ;Defines read-debug-info
  182.  
  183.     (misc debug)        ;Debugging commands: trace, preview, etc.
  184.     (misc inspect)      ;Data structure inspector
  185.     (misc disasm)       ;Disassembler 
  186.     (misc pack)        ;Package system support
  187.  
  188.     (rts xnum)          ;Support for extended numbers
  189.     (rts bignum)        ;Bignum arithmetic - slow but faithful
  190.     (rts ratnum)        ;Rationals
  191.     (rts recnum)        ;Complex numbers (such as they are)
  192.     ))
  193.  
  194. (define thread-files 
  195.   '((misc queue)    ;FIFO queues
  196.     (misc compose-cont) ;Subprimitive used by threads implementation
  197.     (misc thread)    ;Multitasking
  198.     (misc sleep)    ;Multitasking
  199.     ))
  200.  
  201. (define misc-files
  202.   '(
  203.     (boot p-features)   ;Can replace s48-features.scm
  204.     (boot t-features)   ;Can replace s48-features.scm
  205.     (boot p-record)     ;Can replace s48-record.scm
  206.     (boot t-record)     ;Can replace s48-record.scm
  207.     (boot record)    ;Can replace s48-record.scm
  208.     (boot testsys)    ;For making a tiny image that says hello
  209.     (boot little)    ;For making a tiny read-eval-print loop
  210.     (boot package-defs) ;Package setup for for-debugging.scm
  211.     (boot for-debugging) ;For debugging new runtime systems
  212.  
  213.     (misc package-defs) ;Package setup for things in misc directory
  214.     (misc assem)        ;An assembler
  215.     (misc sort)         ;Online merge sort, thanks to Bob Nix and T project
  216.     (misc random)       ;Random number generator, thanks to T project
  217.     (misc pp)           ;Pretty-printer (internally ugly)
  218.     (misc sicp)        ;Structure & Interpretation compatibility
  219.     (misc tokenize)     ;Read tables (used by pratt.scm)
  220.     (misc pratt)    ;Pratt parser (infix), thanks to Paradigm
  221.     (misc sgol)        ;Sample use of Pratt parser
  222.     (misc sgol-runtime) ;Goes with sgol
  223.     (misc icon)        ;backtracking example
  224.  
  225.     (misc wind-test)    ;Just a test for dynamic-wind
  226.     (misc traverse)    ;Storage leak debugger
  227.  
  228.     ;; Richard's stuff
  229.     (boot byte-code-test)
  230.     (misc bigbit)       ;Bignum bitwise operators
  231.     (misc defrecord)
  232.     (misc xport)        ;Extended port framework
  233.     (misc new-ports)
  234.     (misc format)
  235.     (misc values)       ;Multiple values
  236.  
  237.     (vm load)
  238.     (vm debug-util)
  239.     (vm heap-stack)
  240.     ))
  241.  
  242.  
  243. ; Script: load the Scheme48 linker.
  244.  
  245. (define (load-linker)
  246.   (load-compiler)
  247.   (for-each load-file linker-files)
  248.   (no-value))
  249.  
  250. (define (load-compiler)  ;load compiler only
  251.   (for-each load-file compiler-files)
  252.   (no-value))
  253.  
  254. ; Script: link a Scheme48 system image.
  255.  
  256. (define (link-system)
  257.   (set! *the-system* #f)  ;free up space for GC
  258.   (set! *the-system*
  259.     (make-system (map (lambda (n) (namestring n 'scm))
  260.               rts-files)
  261.              '(usual-resumer bare)
  262.              '#t))
  263.   (write-system *the-system* (namestring system-image-file))
  264.   (write-debug-info (namestring '(boot system debug)))
  265.   (no-value))
  266. (define *the-system* #f)
  267.  
  268. (define (link-little)
  269.   (set! *the-system*
  270.     (make-system (map (lambda (n) (namestring n 'scm))
  271.               (append arch-files
  272.                   base-files
  273.                   rts-files-1
  274.                   '((boot little))))
  275.              '(usual-resumer little)
  276.              '#t))
  277.   (write-system *the-system* (namestring '(boot little image))))
  278.  
  279.  
  280.  
  281. ; Convert a namelist '(foo bar) into a string "foo/bar.scm"
  282.  
  283. ; This is Unix-specific, unfortunately.  I guess that's unavoidable.
  284.  
  285. (define (namestring namelist . maybe-default-type)
  286.   (let* ((default-type (if (null? maybe-default-type)
  287.                *default-default-file-type*
  288.                (car maybe-default-type)))
  289.      (type (if (null? (cddr namelist))
  290.            default-type
  291.            (caddr namelist))))
  292.     (string-append *scheme48-file-prefix*
  293.            (namestring-component (car namelist))
  294.            "/"
  295.            (namestring-component (cadr namelist))
  296.            (if type
  297.                (string-append "."
  298.                       (namestring-component type))
  299.                ""))))
  300.  
  301. (define (namestring-component x)
  302.   (cond ((string? x) x)
  303.     ((symbol? x)
  304.      (list->string (map char-downcase
  305.                 (string->list (symbol->string x)))))
  306.     (else (error "bogus namelist component" x))))
  307.  
  308. ; (write-makefile "~/s48/Makefile.filenames")
  309. ;  or  % make Makefile.filenames
  310.  
  311. (define (write-makefile target)
  312.   (set! *scheme48-file-prefix* "")      ;?
  313.   (call-with-output-file target
  314.     (lambda (port)
  315.       (display "#### Do not edit this file.  Edit files.scm instead. ####"
  316.            port)
  317.       (newline port)
  318.       (newline port)
  319.       (let* ((all-files '())
  320.          (foo (lambda (var files)
  321.            (display var port)
  322.            (display " = " port)
  323.            (for-each (lambda (file)
  324.                    (if (not (member file all-files))
  325.                    (set! all-files (cons file all-files)))
  326.                    (display (namestring file 'scm) port)
  327.                    (display " " port))
  328.                  files)
  329.            (newline port))))
  330.     (foo "SYSTEM_IMAGE" (list system-image-file))
  331.     ;; The following is a kludge to prevent boot/system.image from going
  332.     ;; into the distribution.
  333.     (set! all-files '())
  334.     (foo "RTSFILES" rts-files)
  335.     (foo "COMPILERFILES" compiler-files)
  336.     (foo "LINKERFILES" linker-files)
  337.     (foo "QUICKLYFILES" quickly-files)
  338.     (foo "EXTRAFILES" extra-files)
  339.     (foo "OTHERFILES" (append vm-files
  340.                   vm-debug-files
  341.                   thread-files
  342.                   misc-files))
  343.     (foo "ALLFILES" (reverse all-files))))))
  344.