home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / global.scm < prev    next >
Text File  |  2000-01-09  |  9KB  |  308 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: global.scm,v 14.52 2000/01/10 03:35:47 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Miscellaneous Global Definitions
  23. ;;; package: ()
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Primitive Operators
  28.  
  29. (define-primitives
  30.   force error-procedure
  31.   set-interrupt-enables! enable-interrupts! with-interrupt-mask
  32.   get-fixed-objects-vector with-history-disabled
  33.   (primitive-procedure-arity 1)
  34.   (primitive-procedure-documentation 1)
  35.  
  36.   ;; Environment
  37.   lexical-reference lexical-assignment local-assignment
  38.   lexical-unassigned? lexical-unbound? lexical-unreferenceable?
  39.  
  40.   ;; Pointers
  41.   (object-type 1)
  42.   (object-gc-type 1)
  43.   (object-datum 1)
  44.   (object-type? 2)
  45.   (object-new-type object-set-type 2)
  46.   make-non-pointer-object
  47.   eq?
  48.  
  49.   ;; Cells
  50.   make-cell cell? cell-contents set-cell-contents!
  51.  
  52.   ;; System Compound Datatypes
  53.   system-pair-cons system-pair?
  54.   system-pair-car system-pair-set-car!
  55.   system-pair-cdr system-pair-set-cdr!
  56.  
  57.   hunk3-cons
  58.   system-hunk3-cxr0 system-hunk3-set-cxr0!
  59.   system-hunk3-cxr1 system-hunk3-set-cxr1!
  60.   system-hunk3-cxr2 system-hunk3-set-cxr2!
  61.  
  62.   (system-list->vector system-list-to-vector)
  63.   (system-subvector->list system-subvector-to-list)
  64.   system-vector?
  65.   (system-vector-length system-vector-size)
  66.   system-vector-ref
  67.   system-vector-set!)
  68.  
  69. ;;;; Potpourri
  70.  
  71. (define (identity-procedure x) x)
  72. (define (null-procedure . args) args '())
  73. (define (false-procedure . args) args false)
  74. (define (true-procedure . args) args true)
  75.  
  76. ;; This definition is replaced when the 
  77. ;; later in the boot sequence.
  78. (define apply (ucode-primitive apply 2))
  79.  
  80. (define (eval expression environment)
  81.   (extended-scode-eval (syntax expression
  82.                    (environment-syntax-table environment))
  83.                environment))
  84.  
  85. (define (scode-eval scode environment)
  86.   (hook/scode-eval scode environment))
  87.  
  88. (define hook/scode-eval
  89.   (ucode-primitive scode-eval))
  90.  
  91. (define-integrable (system-hunk3-cons type cxr0 cxr1 cxr2)
  92.   (object-new-type type (hunk3-cons cxr0 cxr1 cxr2)))
  93.  
  94. (define (object-component-binder get-component set-component!)
  95.   (lambda (object new-value thunk)
  96.     (let ((old-value))
  97.       (shallow-fluid-bind
  98.        (lambda ()
  99.      (set! old-value (get-component object))
  100.      (set-component! object new-value)
  101.      (set! new-value false)
  102.      unspecific)
  103.        thunk
  104.        (lambda ()
  105.      (set! new-value (get-component object))
  106.      (set-component! object old-value)
  107.      (set! old-value false)
  108.      unspecific)))))
  109.  
  110. (define (bind-cell-contents! cell new-value thunk)
  111.   (let ((old-value))
  112.     (shallow-fluid-bind
  113.      (lambda ()
  114.        (set! old-value (cell-contents cell))
  115.        (set-cell-contents! cell new-value)
  116.        (set! new-value)
  117.        unspecific)
  118.      thunk
  119.      (lambda ()
  120.        (set! new-value (cell-contents cell))
  121.        (set-cell-contents! cell old-value)
  122.        (set! old-value)
  123.        unspecific))))
  124.  
  125. (define (values . objects)
  126.   (lambda (receiver)
  127.     (apply receiver objects)))
  128.  
  129. (define (call-with-values thunk receiver)
  130.   ((thunk) receiver))
  131.  
  132. (define with-values call-with-values)
  133.  
  134. (define (write-to-string object #!optional max)
  135.   (if (or (default-object? max) (not max))
  136.       (with-output-to-string (lambda () (write object)))
  137.       (with-output-to-truncated-string max (lambda () (write object)))))
  138.  
  139. (define (pa procedure)
  140.   (cond ((not (procedure? procedure))
  141.      (error "Must be a procedure" procedure))
  142.     ((procedure-lambda procedure)
  143.      => (lambda (scode)
  144.           (pp (unsyntax-lambda-list scode))))
  145.     ((and (primitive-procedure? procedure)
  146.           (primitive-procedure-documentation procedure))
  147.      => (lambda (documentation)
  148.           (display documentation)
  149.           (newline)))
  150.     (else
  151.      (display "No documentation or debugging info for ")
  152.      (display procedure)
  153.      (display ".")
  154.      (newline))))
  155.  
  156. (define (pwd)
  157.   (working-directory-pathname))
  158.  
  159. (define (cd #!optional pathname)
  160.   (set-working-directory-pathname!
  161.     (if (default-object? pathname)
  162.         (user-homedir-pathname)
  163.      pathname)))
  164.  
  165. (define (show-time thunk)
  166.   (let ((process-start (process-time-clock))
  167.     (process-start/nogc (runtime))
  168.     (real-start (real-time-clock)))
  169.     (let ((value (thunk)))
  170.       (let* ((process-end (process-time-clock))
  171.          (process-end/nogc (runtime))
  172.          (real-end (real-time-clock))
  173.          (process-time (- process-end process-start))
  174.          (process-time/nogc
  175.           (round->exact (* 1000 (- process-end/nogc process-start/nogc)))))
  176.     (write-string "process time: ")
  177.     (write process-time)
  178.     (write-string " (")
  179.     (write process-time/nogc)
  180.     (write-string " RUN + ")
  181.     (write (- process-time process-time/nogc))
  182.     (write-string " GC); real time: ")
  183.     (write (- real-end real-start))
  184.     (newline))
  185.       value)))
  186.  
  187. (define (wait-interval ticks)
  188.   (let ((end (+ (real-time-clock) ticks)))
  189.     (let wait-loop ()
  190.       (if (< (real-time-clock) end)
  191.       (wait-loop)))))
  192.  
  193. (define (exit #!optional integer)
  194.   (hook/exit (if (default-object? integer) false integer)))
  195.  
  196. (define (default/exit integer)
  197.   (if (prompt-for-confirmation "Kill Scheme")
  198.       (%exit integer)))
  199.  
  200. (define hook/exit default/exit)
  201.  
  202. (define (%exit #!optional integer)
  203.   (event-distributor/invoke! event:before-exit)
  204.   (if (or (default-object? integer)
  205.       (not integer))
  206.       ((ucode-primitive exit 0))
  207.       ((ucode-primitive exit-with-value 1) integer)))
  208.  
  209. (define (quit)
  210.   (hook/quit))
  211.  
  212. (define (%quit)
  213.   (with-absolutely-no-interrupts (ucode-primitive halt))
  214.   unspecific)
  215.  
  216. (define default/quit %quit)
  217. (define hook/quit default/quit)
  218.  
  219. (define syntaxer/default-environment
  220.   (let () (the-environment)))
  221.  
  222. (define user-initial-environment
  223.   (let () (the-environment)))
  224.  
  225. (define user-initial-prompt
  226.   "]=>")
  227.  
  228. (define (environment-link-name to from name)
  229.   ((ucode-primitive environment-link-name)
  230.    (->environment to)
  231.    (->environment from)
  232.    name))
  233.  
  234. (define-integrable (object-non-pointer? object)
  235.   (zero? (object-gc-type object)))
  236.  
  237. (define-integrable (object-pointer? object)
  238.   (not (object-non-pointer? object)))
  239.  
  240. (define (impurify object)
  241.   (if (and (object-pointer? object) (object-pure? object))
  242.       ((ucode-primitive primitive-impurify) object))
  243.   object)
  244.  
  245. (define (fasdump object filename
  246.          #!optional suppress-messages? dump-option)
  247.   (let* ((filename (->namestring (merge-pathnames filename)))
  248.      (do-it
  249.       (lambda (start-message end-message)
  250.         (start-message)
  251.         (let loop ()
  252.           (if ((ucode-primitive primitive-fasdump)
  253.            object filename
  254.            (if (default-object? dump-option)
  255.                false
  256.                dump-option))
  257.           (end-message)
  258.           (begin
  259.             (with-simple-restart 'RETRY "Try again."
  260.               (lambda ()
  261.             (error "FASDUMP: Object is too large to be dumped:"
  262.                    object)))
  263.             (loop))))))
  264.      (no-print (lambda () unspecific)))
  265.     (if (or (default-object? suppress-messages?)
  266.         (not suppress-messages?))
  267.     (let ((port (notification-output-port)))
  268.       (do-it (lambda ()
  269.            (fresh-line port)
  270.            (write-string ";Dumping " port)
  271.            (write (enough-namestring filename) port))
  272.          (lambda ()
  273.            (write-string " -- done" port)
  274.            (newline port))))
  275.     (do-it no-print no-print))))
  276.  
  277. (define (undefined-value? object)
  278.   ;; Note: the unparser takes advantage of the fact that objects
  279.   ;; satisfying this predicate also satisfy:
  280.   ;; (object-type? (microcode-type 'CONSTANT) object)
  281.   (or (eq? object undefined-conditional-branch)
  282.       ;; same as `undefined-conditional-branch'.
  283.       ;; (eq? object *the-non-printing-object*)
  284.       ;; (eq? object unspecific)
  285.       (eq? object (microcode-object/unassigned))))
  286.  
  287. (define unspecific
  288.   (object-new-type (ucode-type constant) 1))
  289.  
  290. (define *the-non-printing-object*
  291.   unspecific)
  292.  
  293. (define (obarray->list #!optional obarray)
  294.   (let ((obarray
  295.      (if (default-object? obarray)
  296.          (fixed-objects-item 'OBARRAY)
  297.          obarray)))
  298.     (let per-bucket
  299.     ((index (fix:- (vector-length obarray) 1))
  300.      (accumulator '()))
  301.       (if (fix:< index 0)
  302.       accumulator
  303.       (let per-symbol
  304.           ((bucket (vector-ref obarray index))
  305.            (accumulator accumulator))
  306.         (if (null? bucket)
  307.         (per-bucket (fix:- index 1) accumulator)
  308.         (per-symbol (cdr bucket) (cons (car bucket) accumulator))))))))