home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / run-functions.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  11.8 KB  |  329 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: runtime-functions.scm,v 1.25 1992/09/11 21:23:40 jmiller Exp $
  39.  
  40. ;;;; Miscellaneous Dylan Functions
  41.  
  42. ;;;
  43. ;;; Specialized MAKE for some built in classes
  44. ;;;
  45. (add-method dylan:make
  46.   (dylan::function->method
  47.     (make-param-list `((CLASS ,(dylan::make-singleton <generic-function>)))
  48.              #F #F '(debug-name: required: rest?: key?:))
  49.     (lambda (class . rest)
  50.       class                ; ignored
  51.       (let ((name (dylan::find-keyword rest 'debug-name:
  52.                        (lambda ()
  53.                      "Anonymous Generic Function")))
  54.         (nrequired
  55.          (dylan::find-keyword
  56.           rest 'required:
  57.           (lambda ()
  58.         (dylan-call dylan:error "(make (singleton <generic-function>)) -- required: not supplied" class rest))))
  59.         (rest? (dylan::find-keyword rest 'rest?: (lambda () #F)))
  60.         (keys (dylan::find-keyword rest 'key?: (lambda () #F))))
  61.     (dylan::create-generic-function name nrequired keys rest?)))))
  62.  
  63. (add-method dylan:make
  64.   (dylan::function->method
  65.     (make-param-list
  66.      `((CLASS ,(dylan::make-singleton <singleton>))) #F #F '(object:))
  67.     (lambda (class . rest)
  68.       class                ; ignored
  69.       (let ((object (dylan::find-keyword
  70.              rest 'object:
  71.              (lambda ()
  72.                (dylan-call dylan:error "(make (singleton <singleton>)) -- object not supplied" class rest)))))
  73.     (dylan::make-singleton object)))))
  74.  
  75. (add-method dylan:make
  76.   (dylan::function->method
  77.     (make-param-list `((CLASS ,(dylan::make-singleton <complex>)))
  78.              #F #F '(real: imag: magnitude: angle:))
  79.     (lambda (class . rest)
  80.       class                ; Ignored
  81.       (let ((real (dylan::find-keyword rest 'real: (lambda () #F)))
  82.         (imag (dylan::find-keyword rest 'imag: (lambda () #F)))
  83.         (mag (dylan::find-keyword rest 'magnitude: (lambda () #F)))
  84.         (angle (dylan::find-keyword rest 'angle: (lambda () #F))))
  85.     (cond ((and (not real) (not imag) (not mag) (not angle))
  86.            (dylan-call dylan:make-rectangular 0 0))
  87.           ((and real (not imag) (not mag) (not angle))
  88.            (dylan-call dylan:make-rectangular real 0))
  89.           ((and (not real) imag (not mag) (not angle))
  90.            (dylan-call dylan:make-rectangular 0 imag))
  91.           ((and real imag (not mag) (not angle))
  92.            (dylan-call dylan:make-rectangular real imag))
  93.           ((and (not real) (not imag) mag (not angle))
  94.            (dylan-call dylan:make-polar mag 0))
  95.           ((and (not real) (not imag) (not mag) angle)
  96.            (dylan-call dylan:make-polar 0 angle))
  97.           ((and (not real) (not imag) mag angle)
  98.            (dylan-call dylan:make-polar mag angle))
  99.           (else
  100.            (dylan-call dylan:error "(make (singleton <complex>)) -- invalid keyword combination" class rest)))))))
  101.  
  102.  
  103. ;;;
  104. ;;; Misc Generic Functions
  105. ;;;
  106. (define dylan:find-method
  107.   (dylan::generic-fn 'find-method
  108.     (make-param-list `((GENERIC-FUNCTION ,<generic-function>)
  109.                (SPECIALIZERS ,<list>)) #F #F #F)
  110.     find-method))
  111.  
  112. (define dylan:generic-function-methods
  113.   (dylan::generic-fn 'generic-function-methods
  114.     (make-param-list `((GENERIC-FUNCTION ,<generic-function>)) #F #F #F)
  115.     (lambda (generic-function)
  116.       (generic-function.methods generic-function))))
  117.  
  118. (define dylan:acosh
  119.   (dylan::generic-fn 'acosh
  120.     one-number
  121.     (lambda (z)
  122.       (log (+ z (* (+ z 1) (sqrt (/ (- z 1) (+ z 1)))))))))
  123.  
  124. (define dylan:asinh
  125.   (dylan::generic-fn 'asinh
  126.     one-number
  127.     (lambda (z)
  128.       (log (+ z (sqrt (+ 1 (* z z))))))))
  129.  
  130. (define dylan:atanh
  131.   (dylan::generic-fn 'atanh
  132.     one-number
  133.     (lambda (z)
  134.       (log (* (+ 1 z) (sqrt (/ 1 (- 1 (* z z)))))))))
  135.  
  136. (define dylan:cosh
  137.   (dylan::generic-fn 'cosh
  138.     one-number
  139.     (lambda (z)
  140.       (/ (+ (exp z) (exp (- z))) 2))))
  141.  
  142. (define dylan:sinh
  143.   (dylan::generic-fn 'sinh
  144.      one-number
  145.      (lambda (z)
  146.        (/ (- (exp z) (exp (- z))) 2))))
  147.  
  148. (define dylan:tanh
  149.   (dylan::generic-fn 'tanh
  150.      one-number
  151.      (lambda (z)
  152.        (/ (- (exp z) (exp (- z)))
  153.       (+ (exp z) (exp (- z)))))))
  154.  
  155. (define dylan:add-slot
  156.   (dylan::generic-fn 'add-slot
  157.    (make-param-list `((SLOT-OWNER ,<object>))
  158.             #F #F '(getter: setter: type: init-value:
  159.                     init-function: init-keyword:
  160.                     required-init-keyword: debug-name:
  161.                     allocation:))
  162.    add-slot))
  163.  
  164. (define dylan:freeze-methods
  165.   (dylan::generic-fn 'freeze-methods
  166.     (make-param-list `((GENERIC-FUNCTION ,<generic-function>)) #F #T #F)
  167.     (lambda (generic-function . specializers)
  168.       specializers            ; Ignored for now
  169.       generic-function)))
  170.  
  171. (define dylan:function-arguments
  172.   (dylan::generic-fn 'function-arguments
  173.              (make-param-list `((FN ,<function>)) #F #F #F)
  174.              #F))
  175. (begin
  176.   (add-method dylan:function-arguments
  177.     (dylan::dylan-callable->method
  178.      (make-param-list `((METHOD ,<method>)) #F #F #F)
  179.      (lambda (multiple-values next-method method)
  180.        (dylan-full-call dylan:values multiple-values next-method
  181.             (method.nrequired method)
  182.             (method.rest? method)
  183.             (method.keys method)))))
  184.   (add-method dylan:function-arguments
  185.     (dylan::dylan-callable->method
  186.      (make-param-list `((GENERIC-FUNCTION ,<generic-function>)) #F #F #F)
  187.      (lambda (multiple-values next-method generic-function)
  188.        (dylan-full-call dylan:values multiple-values next-method
  189.             (generic-function.nrequired generic-function)
  190.             (generic-function.rest? generic-function)
  191.             (generic-function.keys generic-function))))))
  192.  
  193. (define dylan:make-polar
  194.   (dylan::generic-fn 'make-polar two-reals
  195.     (lambda (magnitude angle)
  196.       (if (zero? angle)
  197.       magnitude
  198.       (+ (* magnitude (cos angle))
  199.          (* magnitude (sin angle) (get-+i)))))))
  200.  
  201. (define dylan:make-rectangular
  202.   (dylan::generic-fn 'make-rectangular two-reals
  203.     (lambda (real imaginary)
  204.       (if (zero? imaginary)
  205.       real
  206.       (+ real (* (get-+i) imaginary))))))
  207.  
  208. (define dylan:method-specializers
  209.   (dylan::generic-fn 'method-specializers
  210.     (make-param-list `((METHOD ,<method>)) #F #F #F)
  211.     (lambda (method) (method.specializers method))))
  212.  
  213. (define dylan:singleton
  214.   (dylan::generic-fn 'singleton one-object dylan::make-singleton))
  215.  
  216. (define dylan:sorted-applicable-methods
  217.   (dylan::generic-fn 'sorted-applicable-methods
  218.     (make-param-list `((GENERIC-FUNCTION ,<generic-function>)) #F #T #F)
  219.     (lambda (generic-function . args)
  220.       (sorted-applicable-methods
  221.        (generic-function.methods generic-function)
  222.        args))))
  223.  
  224. (define dylan:remove-method
  225.   (dylan::generic-fn 'remove-method
  226.     (make-param-list `((GENERIC-FUNCTION ,<generic-function>)
  227.                (METHOD ,<method>)) #F #F #F)
  228.     (lambda (generic-function method)
  229.       (if (generic-function.read-only? generic-function)
  230.       (dylan-call dylan:error
  231.               "remove-method -- generic function is read-only"
  232.               generic-function method))
  233.       (delete-method! generic-function method))))
  234.  
  235. (define dylan:slot-descriptor
  236.   ;; I'm ignoring the problem of making singletons of
  237.   ;; Scheme-native immutable objects, and adding slots to the
  238.   ;; singleton.
  239.   (dylan::generic-fn 'slot-descriptor
  240.     (make-param-list `((INSTANCE ,<object>)
  241.                (GETTER ,<generic-function>)) #F #F #F)
  242.     (lambda (obj getter)
  243.       (or (and (instance? obj)
  244.            (instance.singleton obj)
  245.            (same-slot-getter-in-slot-vector->slot
  246.         getter
  247.         (singleton.extra-slot-descriptors
  248.          (instance.singleton obj))))
  249.       (same-slot-getter-in-slot-vector->slot
  250.        getter
  251.        (class.slots (get-type obj)))))))
  252.  
  253. (define dylan:slot-value
  254.   (dylan::generic-fn 'slot-value
  255.     (make-param-list `((INSTANCE ,<object>)
  256.                (SLOT-DESC ,<slot-descriptor>)) #F #F #F)
  257.     (lambda (instance slot-desc)
  258.       (let ((allocation (slot.allocation slot-desc))
  259.         (loc (slot.data-location slot-desc)))
  260.     (case allocation
  261.       ((INSTANCE) (vector-ref instance loc))
  262.       ((CLASS) (vector-ref (class.class-data (car loc)) (cdr loc)))
  263.       ((EACH-SUBCLASS) (vector-ref (get-type instance) loc))
  264.       ((VIRTUAL) ((slot.getter slot-desc) instance))
  265.       ((CONSTANT) loc)
  266.       (else (dylan-call dylan:error
  267.                 "slot-value -- internal error"
  268.                 slot-desc allocation)))))))
  269.  
  270. (define dylan:setter/slot-value/
  271.   (dylan::generic-fn 'slot-value
  272.     (make-param-list `((INSTANCE ,<object>)
  273.                (SLOT-DESC ,<slot-descriptor>)
  274.                (NEW-VALUE ,<object>)) #F #F #F)
  275.     (lambda (instance slot-desc new-value)
  276.       (if (not (match-specializer? new-value (slot.type slot-desc)))
  277.       (dylan-call dylan:error
  278.               "(setter slot-value) -- type conflict"
  279.               instance (slot.type slot-desc)
  280.               slot-desc new-value))
  281.       (let ((allocation (slot.allocation slot-desc))
  282.         (loc (slot.data-location slot-desc)))
  283.     (case allocation
  284.       ((INSTANCE) (vector-set! instance loc new-value))
  285.       ((CLASS)
  286.        (vector-set! (class.class-data (car loc)) (cdr loc) new-value))
  287.       ((EACH-SUBCLASS) (vector-set! (get-type instance) loc new-value))
  288.       ((VIRTUAL)
  289.        (let ((setter (slot.setter slot-desc)))
  290.          (if (not setter)
  291.          (dylan-call dylan:error
  292.                  "(setter slot-value) -- no setter for virtual slot"
  293.                  instance slot-desc new-value))
  294.          (setter instance new-value))
  295.        ((slot.setter slot-desc) instance))
  296.       ((CONSTANT)
  297.        (dylan-call dylan:error
  298.                "(setter slot-value) -- can't set a constant slot"
  299.                instance slot-desc new-value))
  300.       (else (dylan-call dylan:error
  301.                 "(setter slot-value) -- internal error"
  302.                 slot-desc allocation)))))))
  303.  
  304. (define dylan:make-read-only
  305.   (dylan::generic-fn 'make-read-only one-class
  306.     (lambda (class)
  307.       (set-class.read-only?! class #T)
  308.       class)))
  309. (add-method dylan:make-read-only
  310.  (dylan::function->method
  311.   (make-param-list `((GENERIC-FUNCTION ,<generic-function>)) #F #F #F)
  312.   (lambda (generic-function)
  313.     (set-generic-function.read-only?! generic-function #T))))
  314.  
  315. (define dylan:seal
  316.   (dylan::generic-fn 'seal one-class
  317.     (lambda (class)
  318.       (set-class.sealed?! class #T)
  319.       class)))
  320.  
  321. (define dylan:remove-slot #F)
  322.  
  323. ;;;;;;;;;;;; CRL additions
  324.  
  325. (define dylan:display (make-dylan-callable display 1))
  326. (define dylan:newline (make-dylan-callable newline 0))
  327. (define dylan:write-line (make-dylan-callable write-line 1))
  328. (define dylan:print (make-dylan-callable write-line 1))
  329.