home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / implementation-specific.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  9.9 KB  |  295 lines  |  [TEXT/gamI]
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;*
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;*
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;*
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: gambit-specific.scm,v 1.6 1992/09/23 19:29:03 birkholz Exp $
  39.  
  40. ;;;; This file contains the definitions of all functions used in the
  41. ;;;; implementation of Dylan which aren't part of R4RS.
  42.  
  43. ;;;; Populations
  44.  
  45. ;(load "poplat")
  46.  
  47. ;;;; Hash tables that use weak links for objects
  48.  
  49. ;(load "hash")
  50.  
  51. ;;;; Record package
  52.  
  53. (define (error:wrong-type-argument record-type expected-type procedure)
  54.   (error (string-append
  55.            "Record package,"
  56.            (symbol->string procedure)
  57.            ": wrong argument type.  Expected "
  58.            expected-type
  59.            ", got ")
  60.          record-type))
  61.  
  62. (define (error:bad-range-argument field-name procedure-name)
  63.   (error (string-append
  64.            "Record package,"
  65.            (symbol->string procedure-name)
  66.            ": unknown field name")
  67.          field-name))
  68.  
  69. ;(load "record")
  70.  
  71. ;;;; Compiler's error procedure.
  72.  
  73. (define (dylan::error string . args)
  74.   (apply error (string-append "Error: " string) args))
  75.  
  76. ;;;; Load-up
  77.  
  78. (define (implementation-specific:generate-file in-exprs out-expr)
  79.   (define (print x) (newline) (display x))
  80.   (define (pp-to-string exprs)
  81.     (let ((port (open-output-string)))
  82.       (for-each (lambda (x) (newline port) (pp x port))
  83.         exprs)
  84.       (let ((str (get-output-string port)))
  85.     (close-output-port port)
  86.     str)))
  87.   (define (split-char-list chars continue)
  88.     (let loop ((output '())
  89.            (chars chars))
  90.       (cond ((null? chars)
  91.          (continue (list->string (reverse output)) '()))
  92.         ((char=? (car chars) #\newline)
  93.          (continue (list->string (reverse output)) (cdr chars)))
  94.         (else (loop (cons (car chars) output) (cdr chars))))))
  95.   (define (string->strings string)
  96.     (let loop ((output '())
  97.            (input (string->list string)))
  98.       (if (null? input)
  99.       (reverse output)
  100.       (split-char-list input
  101.         (lambda (string rest-chars)
  102.           (loop (cons string output) rest-chars))))))
  103.   (print ";;;; Input expressions:")
  104.   (for-each (lambda (line)
  105.           (if (not (zero? (string-length line))) (display "; "))
  106.           (display line)
  107.           (newline))
  108.         (string->strings (pp-to-string in-exprs)))
  109.   (print ";;;; Compiled output:")
  110.   (newline)
  111.   (print "(##declare (standard-bindings) (not safe))")
  112.   (newline)
  113.   (pp out-expr)
  114.   (newline))
  115.  
  116. ;;;; Eval
  117.  
  118. (define (implementation-specific:eval expression)
  119.   (eval expression))
  120.  
  121. ;;;; Interface between Dylan condition system (runtime-exceptions.scm) and
  122. ;;;; native condition system.
  123.  
  124. (define *dylan-handlers* '())
  125.  
  126. (define (implementation-specific:push-handler
  127.      type function test description thunk)
  128.   (dynamic-wind
  129.    (lambda ()
  130.      (set! *dylan-handlers* (cons (list type function test description)
  131.                   *dylan-handlers*)))
  132.    thunk
  133.    (lambda ()
  134.      (set! *dylan-handlers* (cdr *dylan-handlers*)))))
  135.  
  136. (define (implementation-specific:get-dylan-handler-frames)
  137.   *dylan-handlers*)
  138.  
  139. (define (implementation-specific:enter-debugger dylan-condition)
  140.   ;; implementation-specific:enter-debugger is only called by `break',
  141.   ;; so I label the ##debug-repl with "*** Breakpoint".
  142.   ;; Printing the arguments to `break':
  143.   (##call-with-current-continuation
  144.     (lambda (cont)
  145.       (##sequentially
  146.         (lambda ()
  147.           (let ((out (##repl-out)))
  148.             (##newline out)
  149.             (##write-string
  150.              (dylan-call dylan:condition-format-string dylan-condition)
  151.              out)
  152.             (##newline)
  153.             (##newline out)
  154.             (##write-string "*** Breakpoint" out)
  155.             (##newline out)
  156.             (##debug-repl cont)))))))
  157.  
  158. (define (implementation-specific:induce-error format-string format-args)
  159.   (apply error format-string format-args))
  160.  
  161. (define (implementation-specific:induce-type-error value class-name)
  162.   (error (string-append "not an instance of " (symbol->string class-name) ":")
  163.     value))
  164.  
  165. (define (implementation-specific:signal-unhandled-dylan-condition
  166.          dylan-condition)
  167.   (error "unhandled condition:" dylan-condition))
  168.  
  169. (define (implementation-specific:warning format-string format-args)
  170.   (newline) (display "*** WARNING -- ")
  171.   (display-simple-error format-string format-args))
  172.  
  173. (define (display-simple-error format-string format-args)
  174.   (display format-string)
  175.   (do ((args format-args (cdr args)))
  176.       ((null? args) #t)
  177.     (display " ")(write (car args))))
  178.  
  179. ;;; Gambit errors consist of constant objects denoting the error type,
  180. ;;; plus a list of "args".  To hand both pieces of info to the Thomas
  181. ;;; error reflector, cons them together.  Here're the operations.
  182. (define make-condition (lambda (x y) (cons x '())))
  183. (define condition-type car)
  184. (define condition-args cdr)
  185.  
  186. (define (implementation-specific:catch-all-errors handler thunk)
  187.   (##catch-all (lambda (s args) (handler (make-condition s args))) thunk))
  188.  
  189. ;;; All gambit errors will be reflected as <simple-errors>.  We
  190. ;;; convert any types to some, usually descriptive, string.
  191.  
  192. (define (implementation-specific:get-error-message scheme-condition)
  193.   (let ((s (condition-type scheme-condition)))
  194.     (case s
  195.       ((##SIGNAL.IO-ERROR)
  196.        "io-error")
  197.       ((##SIGNAL.READ-ERROR)
  198.        "read-error")
  199.       ((##SIGNAL.UNBOUND-DYNAMIC-VAR)
  200.        "unbound-dynamic-var")
  201.       ((##SIGNAL.GLOBAL-UNBOUND)
  202.        "global-unbound")
  203.       ((##SIGNAL.GLOBAL-UNBOUND-OPERATOR)
  204.        "global-unbound-operator")
  205.       ((##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR)
  206.        "global-non-procedure-operator")
  207.       ((##SIGNAL.NON-PROCEDURE-JUMP)
  208.        "non-procedure-jump")
  209.       ((##SIGNAL.NON-PROCEDURE-OPERATOR)
  210.        "non-procedure-operator")
  211.       ((##SIGNAL.NON-PROCEDURE-SEND)
  212.        "non-procedure-send")
  213.       ((##SIGNAL.WRONG-NB-ARG)
  214.        "wrong-nb-arg")
  215.       ((##SIGNAL.APPLY-ARG-LIMIT)
  216.        "apply-arg-limit")
  217.       ((##SIGNAL.HEAP-OVERFLOW)
  218.        "heap-overflow")
  219.       ((##SIGNAL.STACK-OVERFLOW)
  220.        "stack-overflow")
  221.       ((##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED)
  222.        "placeholder-already-determined")
  223.       ((##SIGNAL.RUNTIME-ERROR)
  224.        "runtime-error")
  225.       ((##SIGNAL.GLOBAL-ENV-OVERFLOW)
  226.        "global-env-overflow")
  227.       ((##SIGNAL.SYNTAX-ERROR)
  228.        "syntax-error")
  229.       (else
  230.        "other-error"))))
  231.  
  232. (define (implementation-specific:get-error-arguments scheme-condition)
  233.   (condition-args scheme-condition))
  234.  
  235. (define (implementation-specific:is-reflected-error? string args)
  236.   ;; Can't tell which <simple-error>s are reflected Gambit errors or
  237.   ;; which are user-generated.  (Actually, if we kept track of the
  238.   ;; above string constants, we could recognize them again.)  I don't
  239.   ;; know how to continue from the catch-all error handler anyway.
  240.   #f)
  241.  
  242. (define (implementation-specific:let-scheme-handle-it serious)
  243.   ;; If implementation-specific:is-reflected-error? always returns #f,
  244.   ;; this should never be called.
  245.   (error "unexpected call to implementation-specific:let-scheme-handle-it"))
  246.  
  247. ;;;; Additional Dylan bindings
  248.  
  249. (define (dylan:scheme-variable-ref mv nm variable-name)
  250.   (eval variable-name))
  251.  
  252. (define (dylan:scheme-procedure-ref mv nm variable-name)
  253.   (make-dylan-callable (eval variable-name)))
  254.  
  255. (define (dylan:pp mv nm obj)
  256.   mv nm                    ; Ignored
  257.   (pp obj))
  258.  
  259. (define (dylan:load mv nm filename)
  260.   (let ((scheme-filename (string-append filename ".scm")))
  261.     (thomas->scheme filename scheme-filename)
  262.     (load scheme-filename)
  263.     filename))
  264.  
  265. (define implementation-specific:additional-dylan-bindings
  266.   `((pp dylan:pp)
  267.     (scheme-variable dylan:scheme-variable-ref)
  268.     (scheme-procedure dylan:scheme-procedure-ref)
  269.     (load dylan:load)))
  270.  
  271. ;;;; Other things
  272.  
  273. ;;; For conversion from strings to symbols, we need a function that
  274. ;;; canonicalizes the case of the string.
  275.  
  276. (define canonicalize-string-for-symbol
  277.   (let ((converter (if (char=? #\a (string-ref (symbol->string 'a) 0))
  278.                char-downcase
  279.                char-upcase)))
  280.     (lambda (string)
  281.       (list->string (map converter (string->list string))))))
  282.  
  283. ;(load "msort")
  284.  
  285. (define (write-line x)
  286.   (write x)
  287.   (newline))
  288.  
  289. ;;; pp -- already provided
  290.  
  291. ;(load "dynwind")
  292.  
  293. ;;; Imaginary numbers aren't supported by all implementations
  294. (define (get-+i) +i)
  295.