home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / bootit.scm < prev    next >
Encoding:
Text File  |  1992-01-30  |  5.9 KB  |  189 lines
  1. ; File bootit.scm / -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ; Booting new Pseudoscheme
  5.  
  6. ; In any Scheme-in-CL implementation, load this file and do
  7. ; (bootit).  This compiles and loads the translator, then invokes
  8. ; the translator to translate itself.
  9.  
  10. ; A fair amount of hacking will be needed before this can be
  11. ; done in a non-Common-Lisp-based Scheme.
  12.  
  13. (define *pseudoscheme-directory* #f)
  14.  
  15. (define (bootit . dir-option)
  16.   (cond ((not (null? dir-option))
  17.      (set! *pseudoscheme-directory* (lisp:pathname (car dir-option))))
  18.     ((not *pseudoscheme-directory*)
  19.      (set! *pseudoscheme-directory*
  20.            (lisp:make-pathname :name 'lisp:nil
  21.                    :type 'lisp:nil
  22.                    :defaults
  23.                      lisp:*default-pathname-defaults*))))
  24.   (init-hacks)
  25.   (load-untranslated-translator)
  26.   (fix-reader-if-necessary)
  27.   (translate-runtime)
  28.   (translate-translator))
  29.  
  30. (define (new-package name use nicks)
  31.   (let ((loser (lisp:find-package name)))
  32.     (lisp:if loser
  33.          (let ((backup (string-append "OLD-" name)))
  34.            (lisp:if (lisp:find-package backup)
  35.             (begin
  36.               (lisp:warn "Using existing ~A package."
  37.                      name)
  38.               (lisp:rename-package loser name nicks)
  39.               (lisp:use-package use loser)
  40.               loser)
  41.             (begin
  42.               (lisp:warn "Renaming existing ~A package to be ~A."
  43.                      name
  44.                      backup)
  45.               (lisp:rename-package loser backup)
  46.               (lisp:make-package name :use use :nicknames nicks))))
  47.          (lisp:make-package name :use use :nicknames nicks))))
  48.  
  49. (define hacks-package #f)
  50. (define clever-load #f)
  51. (define lisp-package #f)
  52. (define scheme-package (lisp:symbol-package 'askdjfh))
  53.  
  54. (define (init-hacks)
  55.   (set! hacks-package
  56.     (new-package "SCHEME-HACKS" '("LISP") '("SCHH")))
  57.   (lisp:let ((lisp:*package* hacks-package))
  58.     (lisp:load (pseudo-pathname "CLEVER") :verbose 'lisp:nil)    ;Get clever file loader
  59.     (set! clever-load (lisp:symbol-function (hack-symbol 'clever-load)))
  60.     ;; Defines a few things used by the translator
  61.     (clever-load (pseudo-pathname "HACKS")
  62.          :compile-if-necessary #t)
  63.     (lisp:funcall (hack-symbol 'fix-scheme-package-if-necessary)
  64.           scheme-package)
  65.     (set! lisp-package (lisp:symbol-value (hack-symbol 'lisp-package)))
  66.     ;; Create SCHI package (translator contains quoted schi:foo's)
  67.     (let ((schi-package (lisp:find-package "SCHI")))
  68.       (lisp:if schi-package
  69.            (begin
  70.          (lisp:rename-package schi-package "SCHI")
  71.          (clever-load (pseudo-pathname "SCHI")))))))
  72.  
  73. ; Make sure that quote and backquote read in properly.
  74. ; Careful, this may cause them to stop working in the Scheme from which
  75. ; we're bootstrapping.  It should be done after all LOAD's and before any
  76. ; READ's.
  77. (define (fix-reader-if-necessary)
  78.   (if (not (eq? (car ''foo) 'quote))
  79.       (lisp:set-macro-character
  80.         #\'
  81.     (lambda (stream c)
  82.       (list ''quote (lisp:read stream 'lisp:t 'lisp:nil 'lisp:t)))))
  83.   (if (not (eq? (car '`(foo)) 'quasiquote))
  84.       (begin (lisp:set-macro-character
  85.           #\`
  86.           (lambda (stream c)
  87.         (list ''quasiquote
  88.               (lisp:read stream 'lisp:t 'lisp:nil 'lisp:t))))
  89.          (lisp:set-macro-character
  90.           #\,
  91.           (lambda (stream c)
  92.         (let* ((following-char
  93.             (lisp:peek-char 'lisp:nil stream
  94.                     'lisp:t 'lisp:nil 'lisp:t))
  95.                (marker (cond ((char=? following-char #\@)
  96.                       (lisp:read-char stream)
  97.                       'unquote-splicing)
  98.                      (else
  99.                       'unquote))))
  100.           (list marker
  101.             (lisp:read stream 'lisp:t 'lisp:nil 'lisp:t))))))))
  102.  
  103. (define (hack-symbol name)
  104.   (lisp:intern (symbol->string name) hacks-package))
  105.  
  106. (define (pseudo-pathname name)
  107.   (lisp:make-pathname :name (preferred-case name)
  108.               :defaults *pseudoscheme-directory*))
  109.  
  110. (define (preferred-case name)
  111.   #+unix (lisp:string-downcase name)
  112.   #-unix name
  113.   )
  114.  
  115. (define *scheme-file-type*     (preferred-case "SCM"))
  116. (define *translated-file-type* (preferred-case "PSO"))
  117. (define *boot-file-type*       (preferred-case "BOOT"))
  118.  
  119. ; Make sure the host system understands that files foo.boot are
  120. ; compiled.
  121.  
  122. #+Lucid
  123. (if (not (member *boot-file-type*
  124.          lucid::*load-binary-pathname-types*))
  125.     (set! lucid::*load-binary-pathname-types*
  126.       (append lucid::*load-binary-pathname-types*
  127.           (list *boot-file-type*))))
  128.  
  129. #+Symbolics
  130. (begin
  131.   (fs:define-canonical-type :boot-bin #,*boot-file-type*)
  132.  
  133.   (set! fs:*auxiliary-loadable-file-types*
  134.     (cons '(:boot-bin :load-stream-function
  135.               si:load-binary-file-internal)
  136.           (lisp:remove :boot-bin fs:*auxiliary-loadable-file-types*
  137.                :key #'car)))
  138.  
  139.   (lisp:setf (lisp:get :boot-bin :binary-file-byte-size)
  140.          (lisp:get :bin :binary-file-byte-size)))
  141.  
  142. ; ----- Load the translator into a scheme emulation
  143.  
  144. (define (load-untranslated-translator)
  145.   ;; Make sure we perform integrations!
  146.   (lisp:if (lisp:fboundp 'go)
  147.        (go 'usual))
  148.   (lisp:if (lisp:fboundp 'benchmark-mode)
  149.        (benchmark-mode))
  150.   (clever-load (pseudo-pathname "FILES")
  151.            #+LispM :package #+LispM scheme-package)
  152.   (for-each load-scheme translator-files)
  153.   'done)
  154.  
  155. (define (load-scheme file)
  156.   (clever-load (pseudo-pathname file)
  157.            :source-type *scheme-file-type*
  158.            :object-type *boot-file-type*
  159.            :compile-if-necessary #t))
  160.  
  161. ; ----- Translating the runtime system
  162.  
  163. (define (translate-runtime)
  164.   ;; In principle, there could be more stuff here.
  165.   (write-closed-definitions
  166.      revised^4-scheme-module
  167.      (lisp:make-pathname :type *translated-file-type*
  168.              :defaults (pseudo-pathname "CLOSED"))))
  169.  
  170. ; ----- Translating the translator
  171.  
  172. (define scheme-translator-env #f)
  173.  
  174. (define (translate-translator)
  175.   (set! scheme-translator-env
  176.     (make-program-env 'scheme-translator
  177.               (list revised^4-scheme-module)))
  178.   (for-each translate-translator-file
  179.         translator-files)
  180.   (translate-translator-file "REFLECT")
  181.   'done)
  182.  
  183. (define (translate-translator-file file)
  184.   (really-translate-file (lisp:make-pathname :type *scheme-file-type*
  185.                          :defaults (pseudo-pathname file))
  186.              (lisp:make-pathname :type *translated-file-type*
  187.                          :defaults (pseudo-pathname file))
  188.              scheme-translator-env))
  189.