home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / sicp / studen.scm < prev    next >
Encoding:
Text File  |  1993-07-17  |  12.9 KB  |  546 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Header: /scheme/sicp/RCS/studen.scm,v 1.8 1991/04/06 06:34:33 jinx Exp $
  4.  
  5. Copyright (c) 1987-91 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. |#
  34.  
  35. ;;;; Environment, syntax and read table hacking for 6.001 students.
  36.  
  37. (declare (usual-integrations))
  38.  
  39. ;;; Define the #/ syntax.
  40.  
  41. (in-package (->environment '(runtime parser))
  42.   (define (parse-object/char-forward-quote)
  43.     (discard-char)
  44.     (if (char=? #\/ (peek-char))
  45.     (read-char)
  46.     (name->char
  47.      (let loop ()
  48.        (cond ((char=? #\/ (peek-char))
  49.           (discard-char)
  50.           (string (read-char)))
  51.          ((char-set-member? char-set/char-delimiters (peek-char))
  52.           (string (read-char)))
  53.          (else
  54.           (let ((string (read-string char-set/char-delimiters)))
  55.             (if (let ((char (peek-char/eof-ok)))
  56.               (and char
  57.                    (char=? #\- char)))
  58.             (begin (discard-char)
  59.                    (string-append string "-" (loop)))
  60.             string))))))))
  61.   
  62.   (define char-set/mit-scheme-atom-delimiters
  63.     char-set/atom-delimiters)
  64.  
  65.   (define char-set/sicp-atom-delimiters
  66.     (char-set-difference
  67.      char-set/mit-scheme-atom-delimiters
  68.      (char-set #\[ #\])))
  69.  
  70.   (define (set-atom-delimiters! kind)
  71.     (set! char-set/atom-delimiters
  72.       (case kind
  73.         ((mit-scheme)
  74.          char-set/mit-scheme-atom-delimiters)
  75.         ((sicp)
  76.          char-set/sicp-atom-delimiters)
  77.         (else
  78.          (error "set-atom-delimiters!: Unknown kind")))))
  79.  
  80. ) ;; end in-package
  81.  
  82. (parser-table/set-entry! system-global-parser-table
  83.              "#\/"
  84.              (access parse-object/char-forward-quote
  85.                  (->environment '(runtime parser))))
  86.  
  87. (define environment-warning-hook)
  88.  
  89. (define user-global-environment)
  90.  
  91. (define student-package
  92.   (make-environment
  93.  
  94. ;;;; Syntax Restrictions
  95.  
  96. (define sicp-parser-table
  97.   (parser-table/copy system-global-parser-table))
  98.  
  99. (define *student-parser-table*)
  100.  
  101. (define sicp-syntax-table
  102.   (make-syntax-table))
  103.  
  104. (define *student-syntax-table*)
  105.  
  106. (define set-atom-delimiters!
  107.   (access set-atom-delimiters! (->environment '(runtime parser))))
  108.  
  109. (define (enable-system-syntax)
  110.   (set-current-parser-table! system-global-parser-table)
  111.   (set-atom-delimiters! 'mit-scheme)
  112.   (set-repl/syntax-table! (nearest-repl) system-global-syntax-table))
  113.  
  114. (define (disable-system-syntax)
  115.   (set-current-parser-table! *student-parser-table*)
  116.   (set-atom-delimiters! 'sicp)
  117.   (set-repl/syntax-table! (nearest-repl) *student-syntax-table*))
  118.  
  119. (define (initialize-syntax!)
  120.   ;; First hack the parser (reader) table
  121.   ;; Remove backquote and comma
  122.   (let ((undefined-entry
  123.      (access parse-object/undefined-atom-delimiter
  124.          (->environment '(runtime parser)))))
  125.     (parser-table/set-entry! sicp-parser-table "`" undefined-entry)
  126.     (parser-table/set-entry! sicp-parser-table "," undefined-entry))
  127.   ;; Add brackets as extended alphabetic since they are used in book (ugh!)
  128.   (parser-table/entry
  129.    system-global-parser-table
  130.    "@"
  131.    (lambda (parse-object collect-list)
  132.      (parser-table/set-entry! sicp-parser-table "[" parse-object collect-list)
  133.      (parser-table/set-entry! sicp-parser-table "]" parse-object
  134.                   collect-list)))
  135.   ;; Now, hack the syntax (special form) table.
  136.   (let ((move
  137.      (lambda (from to)
  138.        (syntax-table-define sicp-syntax-table to
  139.          (or (syntax-table-ref system-global-syntax-table from)
  140.          (error "Missing syntactic keyword" from))))))
  141.     (for-each (lambda (name) (move name name))
  142.           '(
  143.         ;; These special forms are shared.
  144.         COLLECT COND CONS-STREAM DEFINE
  145.         DELAY IF LAMBDA LET MAKE-ENVIRONMENT
  146.         QUOTE SEQUENCE SET! THE-ENVIRONMENT
  147.         ;; The following are needed because some of the above are
  148.         ;; macros and they are not syntactically closed.  Yuck!
  149.         ACCESS BEGIN NAMED-LAMBDA))
  150.     (move 'AND 'CONJUNCTION)
  151.     (move 'OR 'DISJUNCTION))
  152.   (set! *student-parser-table* (parser-table/copy sicp-parser-table))
  153.   (set! *student-syntax-table* (syntax-table/copy sicp-syntax-table))
  154.   #T)
  155.  
  156. ;;;; Global Environment
  157.  
  158. (define (global-environment-enabled?)
  159.   (or (eq? user-global-environment system-global-environment)
  160.       (environment-has-parent? user-global-environment)))
  161.  
  162. (define (in-user-environment-chain? environment)
  163.   (or (eq? environment user-global-environment)
  164.       (and (environment-has-parent? environment)
  165.        (in-user-environment-chain? (environment-parent environment)))))
  166.  
  167. (define ic-environment/remove-parent!)
  168. (define ic-environment/set-parent!)
  169.  
  170. (let ((e (->environment '(runtime environment))))
  171.   (set! ic-environment/remove-parent! (access ic-environment/remove-parent! e))
  172.   (set! ic-environment/set-parent! (access ic-environment/set-parent! e)))
  173.  
  174. (define (disable-global-environment)
  175.   (ic-environment/remove-parent! user-global-environment)
  176.   'DISABLED)
  177.  
  178. (define (enable-global-environment)
  179.   (ic-environment/set-parent! user-global-environment
  180.                   system-global-environment)
  181.   'ENABLED)
  182.  
  183. (define (student-environment-warning-hook environment)
  184.   (if (not (in-user-environment-chain? environment))
  185.       (begin
  186.     (newline)
  187.     (write-string
  188.      "This environment is part of the Scheme system outside the student system.")
  189.     (newline)
  190.     (write-string
  191.      "Performing side-effects in it may damage to the system."))))
  192.  
  193. ;;;; Feature hackery
  194.  
  195. (define (enable-language-features . prompt)
  196.   prompt
  197.   (without-interrupts
  198.    (lambda ()
  199.      (enable-global-environment)
  200.      (enable-system-syntax)))
  201.   unspecific)
  202.  
  203. (define (disable-language-features . prompt)
  204.   prompt
  205.   (without-interrupts
  206.    (lambda ()
  207.      (disable-global-environment)
  208.      (disable-system-syntax)))
  209.   unspecific)
  210.  
  211. (define (language-features-enabled?)
  212.   (global-environment-enabled?))
  213.  
  214. ;;;; Clean environment hackery
  215.  
  216. (define user-global-names
  217.   '(
  218.     (%EXIT)
  219.     (*)
  220.     (*ARGS*)
  221.     (*PROC*)
  222.     (*RESULT*)
  223.     (+)
  224.     (-)
  225.     (-1+)
  226.     (/)
  227.     (1+)
  228.     (<)
  229.     (<=)
  230.     (=)
  231.     (>)
  232.     (>=)
  233.     (ABS)
  234.     (ACCUMULATE)
  235.     (ACCUMULATE-DELAYED)
  236.     (ADD-STREAMS)
  237.     (ADVICE)
  238.     (ADVISE-ENTRY)
  239.     (ADVISE-EXIT)
  240.     (ALPHALESS?)
  241.     (AND . AND*)
  242.     (APPEND)
  243.     (APPEND-STREAMS)
  244.     (APPLICABLE? . PROCEDURE?)
  245.     (APPLY)
  246.     (ASCII)
  247.     (ASSOC)
  248.     (ASSQ)
  249.     (ASSV)
  250.     (ATAN)
  251.     (ATOM?)
  252.     (BKPT)
  253.     (BREAK . BREAK-ENTRY)
  254.     (BREAK-BOTH . BREAK)
  255.     (BREAK-ENTRY)
  256.     (BREAK-EXIT)
  257.     (BREAKPOINT-PROCEDURE)
  258.  
  259.     (CAR)
  260.     (CAAAAR)
  261.     (CAAADR)
  262.     (CAAAR)
  263.     (CAADAR)
  264.     (CAADDR)
  265.     (CAADR)
  266.     (CAAR)
  267.     (CADAAR)
  268.     (CADADR)
  269.     (CADAR)
  270.     (CADDAR)
  271.     (CADDDR)
  272.     (CADDR)
  273.     (CADR)
  274.     (CD)
  275.     (CDR)
  276.     (CDAAAR)
  277.     (CDAADR)
  278.     (CDAAR)
  279.     (CDADAR)
  280.     (CDADDR)
  281.     (CDADR)
  282.     (CDAR)
  283.     (CDDAAR)
  284.     (CDDADR)
  285.     (CDDAR)
  286.     (CDDDAR)
  287.     (CDDDDR)
  288.     (CDDDR)
  289.     (CDDR)
  290.     (CEILING)
  291.     (CHAR)
  292.     (CLEAR-GRAPHICS)
  293.     (CLEAR-POINT)
  294.     (CLOSE-CHANNEL)
  295.     (CONS)
  296.     (CONS*)
  297.     (COPY-FILE)
  298.     (COS)
  299.     (DEBUG)
  300.     (DELETE-FILE)
  301.     (DRAW-LINE-TO)
  302.     (DRAW-POINT)
  303.  
  304.     (EIGHTH)
  305.     (EMPTY-STREAM?)
  306.     (ENABLE-LANGUAGE-FEATURES)
  307.     (ENUMERATE-FRINGE)
  308.     (ENUMERATE-INTERVAL)
  309.     (ENVIRONMENT?)
  310.     (EQ?)
  311.     (EQUAL?)
  312.     (EQV?)
  313.     (ERROR)
  314.     (EVAL)
  315.     (EVEN?)
  316.     (EXP)
  317.     (EXPLODE)
  318.     (EXPT)
  319.     (FALSE)
  320.     (FIFTH)
  321.     (FILE-EXISTS?)
  322.     (FILTER)
  323.     (FIRST)
  324.     (FLATMAP)
  325.     (FLATTEN)
  326.     (FLOOR)
  327.     (FORCE)
  328.     (FOURTH)
  329.     (GCD)
  330.     (GE)
  331.     (GENERATE-UNINTERNED-SYMBOL)
  332.     (GRAPHICS-AVAILABLE?)
  333.     (GRAPHICS-TEXT)
  334.     (HEAD)
  335.     (IMPLODE)
  336.     (IN)
  337.     (INIT-GRAPHICS)
  338.     (INTEGER-DIVIDE)
  339.     (INTEGER?)
  340.     (INTEGERS-FROM)
  341.     (INTEGERS)
  342.     (INTERLEAVE-DELAYED)
  343.     (LAST . LAST-PAIR)
  344.     (LENGTH)
  345.     (LIST)
  346.     (LIST* . CONS*)
  347.     (LIST-REF)
  348.     (LIST-TAIL)
  349.     (LIST?)
  350.     (LOAD)
  351.     (LOAD-NOISILY)
  352.     (LOG)
  353.  
  354.     (MAP-STREAM)
  355.     (MAP-STREAM-2)
  356.     (MAPC . FOR-EACH)
  357.     (MAPCAR . MAP)
  358.     (MAX)
  359.     (MEMBER)
  360.     (MEMQ)
  361.     (MEMV)
  362.     (MERGE)
  363.     (MIN)
  364.     (NEGATIVE?)
  365.     (NEWLINE)
  366.     (NIL)
  367.     (NOT)
  368.     (NTH)
  369.     (NTH-STREAM)
  370.     (NTHCDR)
  371.     (NULL?)
  372.     (NUMBER?)
  373.     (OBJECT-TYPE)
  374.     (ODD?)
  375.     (OPEN-READER-CHANNEL . OPEN-INPUT-FILE)
  376.     (OPEN-PRINTER-CHANNEL . OPEN-OUTPUT-FILE)
  377.     (OR . OR*) 
  378.     (OUT)
  379.     (PAIR?)
  380.     (POSITION-PEN)
  381.     (POSITIVE?)
  382.     (PP . STUDENT-PP)
  383.     (PRIN1 . WRITE)
  384.     (PRINC . DISPLAY)
  385.     (PRINT . WRITE-LINE)
  386.     (PRINT-STREAM)
  387.     (PROCEED)
  388.     (QUIT)
  389.     (QUOTIENT)
  390.     (RANDOM)
  391.     (READ)
  392.     (READ-FROM-KEYBOARD)
  393.     (REMAINDER)
  394.     (RESTART)
  395.     (REVERSE)
  396.     (ROUND)
  397.     (RUNTIME)
  398.     (SCALE-STREAM)
  399.  
  400.     (SECOND)
  401.     (SET-CAR!)
  402.     (SET-CDR!)
  403.     (SEVENTH)
  404.     (SIN)
  405.     (SIXTH)
  406.     (SPREAD-TUPLE)
  407.     (SQRT)
  408.     (STRING-LESS?. STRING<?)
  409.     (SYMBOL?)
  410.     (T)
  411.     (TAIL)
  412.     (TAN)
  413.     (THE-EMPTY-STREAM)
  414.     (THIRD)
  415.     (TRACE . TRACE-ENTRY)
  416.     (TRACE-BOTH . TRACE)
  417.     (TRACE-ENTRY)
  418.     (TRACE-EXIT)
  419.     (TRUE)
  420.     (TRUNCATE)
  421.     (UNADVISE)
  422.     (UNADVISE-ENTRY)
  423.     (UNADVISE-EXIT)
  424.     (UNBREAK)
  425.     (UNBREAK-ENTRY)
  426.     (UNBREAK-EXIT)
  427.     (UNTRACE)
  428.     (UNTRACE-ENTRY)
  429.     (UNTRACE-EXIT)
  430.     (USER-GLOBAL-ENVIRONMENT . #T)
  431.     (USER-INITIAL-ENVIRONMENT . #T)
  432.     (VE)
  433.     (VECTOR)
  434.     (VECTOR-CONS)
  435.     (VECTOR-REF)
  436.     (VECTOR-SET!)
  437.     (VECTOR-SIZE . VECTOR-LENGTH)
  438.     (VECTOR?)
  439.     (WHERE)
  440.     (ZERO?)))
  441.  
  442. ;;; Environment setup code
  443.  
  444. (define (warn-about-missing-objects missing)
  445.   (for-each
  446.    (lambda (name)
  447.      (newline)
  448.      (write-string "Warning -- missing name: ")
  449.      (write name))
  450.    missing))
  451.  
  452. (define (setup-user-global-environment!)
  453.   (define (copy-if-proc object)
  454.     (if (compound-procedure? object)
  455.     (scode-eval (lambda-components (procedure-lambda object)
  456.               make-lambda)
  457.             (procedure-environment object))
  458.     object))
  459.  
  460.   (build-environment
  461.    user-global-names
  462.    system-global-environment    ; Where to look
  463.    system-global-environment    ; Parent frame
  464.    copy-if-proc            ; What to do to each value
  465.    (lambda (frame missing)
  466.      (scode-eval (scode-quote
  467.           (begin
  468.             (set! user-global-environment (the-environment))
  469.             (set! user-initial-environment (make-environment))))
  470.          frame)
  471.      (set! user-global-environment frame)
  472.      (set! user-initial-environment
  473.        (lexical-reference frame 'user-initial-environment))
  474.      (warn-about-missing-objects missing))))
  475.  
  476. ;;;; Saving and restoring the student system
  477.  
  478. (define student-band-pathname)
  479.  
  480. (define (initialize-system)
  481.   (set! init-file-pathname
  482.     (let ((old-init-file-pathname (init-file-pathname)))
  483.       (lambda ()
  484.         (merge-pathnames (make-pathname #f #f #f "sicp" #f #f)
  485.                  old-init-file-pathname))))
  486.   (set! student-band-pathname
  487.     (merge-pathnames
  488.      (make-pathname #f #f #f "sicp" "bin" #f)
  489.      (system-library-directory-pathname false)))
  490.   (add-event-receiver!
  491.    event:after-restart
  492.    (lambda ()
  493.      (if (language-features-enabled?)
  494.      (disable-language-features))
  495.      (if (not (graphics-available?))
  496.      (begin
  497.        (newline)
  498.        (display "*** Note: no graphics available in this system. ***")))))
  499.   #T)
  500.  
  501. (define (reload #!optional filename)
  502.   (disk-restore
  503.    (if (default-object? filename)
  504.        student-band-pathname
  505.        (merge-pathnames (->pathname filename)
  506.             student-band-pathname))))   
  507.  
  508. (define (student-band #!optional filename)
  509.   (if (not (default-object? filename))
  510.       (set! student-band-pathname
  511.         (merge-pathnames (->pathname filename)
  512.                  student-band-pathname)))
  513.   (disk-save student-band-pathname))
  514.  
  515. (define (student-dump filename)
  516.   (dump-world filename))
  517.  
  518. ;;; End STUDENT-PACKAGE.
  519. ))
  520.  
  521. ;;;; Exports
  522.  
  523. (define enable-language-features
  524.   (access enable-language-features student-package))
  525.  
  526. (define disable-language-features
  527.   (access disable-language-features student-package))
  528.  
  529. (define reload
  530.   (access reload student-package))
  531.  
  532. (define student-band
  533.   (access student-band student-package))
  534.  
  535. (define student-dump
  536.   (access student-dump student-package))
  537.  
  538. ;;; Install the student package
  539.  
  540. ((access initialize-syntax! student-package))
  541. ((access setup-user-global-environment! student-package))
  542. ((access initialize-system student-package))
  543. (set! environment-warning-hook
  544.       (access student-environment-warning-hook student-package))
  545. (set-repl/environment! (nearest-repl) user-initial-environment)
  546. (disable-language-features)