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 / generic.scm < prev    next >
Text File  |  1999-01-02  |  14KB  |  417 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: generic.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but 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. ;;;; Generic Procedures
  22.  
  23. (declare (usual-integrations)
  24.      (integrate-external "gentag" "gencache"))
  25.  
  26. ;;;; Generic Procedures
  27.  
  28. (define (make-generic-procedure arity #!optional name tag generator)
  29.   (let ((name (if (default-object? name) #f name))
  30.     (tag (if (default-object? tag) #f tag))
  31.     (generator (if (default-object? generator) #f generator)))
  32.     (if (and name (not (symbol? name)))
  33.     (error:wrong-type-argument name "symbol" 'MAKE-GENERIC-PROCEDURE))
  34.     (if tag (guarantee-dispatch-tag tag 'MAKE-GENERIC-PROCEDURE))
  35.     (if (not (or (and (exact-integer? arity)
  36.               (> arity 0))
  37.          (and (pair? arity)
  38.               (exact-integer? (car arity))
  39.               (> (car arity) 0)
  40.               (or (not (cdr arity))
  41.               (and (exact-integer? (cdr arity))
  42.                    (>= (cdr arity) (car arity)))))))
  43.     (error:wrong-type-argument arity "arity"
  44.                    'MAKE-GENERIC-PROCEDURE))
  45.     (guarantee-generator generator 'MAKE-GENERIC-PROCEDURE)
  46.     (let ((record
  47.        (make-generic-record (or tag standard-generic-procedure-tag)
  48.                 (if (and (pair? arity)
  49.                      (eqv? (car arity) (cdr arity)))
  50.                     (car arity)
  51.                     arity)
  52.                 generator
  53.                 name)))
  54.       (let ((generic (compute-apply-generic record)))
  55.     (set-generic-record/procedure! record generic)
  56.     (eqht/put! generic-procedure-records generic record)
  57.     generic))))
  58.  
  59. (define-structure (generic-record
  60.            (conc-name generic-record/)
  61.            (constructor make-generic-record
  62.                 (tag arity generator name)))
  63.   (tag #f read-only #t)
  64.   (arity #f read-only #t)
  65.   (generator #f)
  66.   (name #f read-only #t)
  67.   (cache (new-cache (if (pair? arity) (car arity) arity)))
  68.   procedure)
  69.  
  70. (define (generic-record/min-arity record)
  71.   (arity-min (generic-record/arity record)))
  72.  
  73. (define (generic-record/max-arity record)
  74.   (arity-max (generic-record/arity record)))
  75.  
  76. (define (arity-min arity)
  77.   (if (pair? arity) (car arity) arity))
  78.  
  79. (define (arity-max arity)
  80.   (if (pair? arity) (cdr arity) arity))
  81.  
  82. (define (generic-procedure? object)
  83.   (if (eqht/get generic-procedure-records object #f) #t #f))
  84.  
  85. (define (generic-procedure-arity generic)
  86.   (generic-record/arity
  87.    (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-ARITY)))
  88.  
  89. (define (generic-procedure-name generic)
  90.   (generic-record/name
  91.    (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-NAME)))
  92.  
  93. (define (generic-procedure-generator generic)
  94.   (generic-record/generator
  95.    (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-GENERATOR)))
  96.  
  97. (define (set-generic-procedure-generator! generic generator)
  98.   (let ((record
  99.      (guarantee-generic-procedure generic
  100.                       'SET-GENERIC-PROCEDURE-GENERATOR!)))
  101.     (guarantee-generator generator 'SET-GENERIC-PROCEDURE-GENERATOR!)
  102.     (without-interrupts
  103.      (lambda ()
  104.        (set-generic-record/generator! record generator)
  105.        (%reset-generic-procedure-cache! record)))))
  106.  
  107. (define (purge-generic-procedure-cache generic #!optional filter)
  108.   (let ((operator
  109.      (if (or (default-object? filter)
  110.          (eq? 'ALL-ENTRIES filter))
  111.          (lambda (generic record)
  112.            generic
  113.            (%reset-generic-procedure-cache! record))
  114.          (lambda (generic record)
  115.            (%purge-generic-procedure-cache! generic record filter)))))
  116.     (if (eq? 'ALL-PROCEDURES generic)
  117.     (eqht/for-each generic-procedure-records operator)
  118.     (operator
  119.      generic
  120.      (guarantee-generic-procedure generic
  121.                       'PURGE-GENERIC-PROCEDURE-CACHE)))))
  122.  
  123. (define (%reset-generic-procedure-cache! record)
  124.   (set-generic-record/cache! record
  125.                  (new-cache (generic-record/min-arity record))))
  126.  
  127. (define (%purge-generic-procedure-cache! generic record filter)
  128.   ;; This might have interrupts locked for a long time, and thus is an
  129.   ;; argument for using something like a semaphore to control access.
  130.   (without-interrupts
  131.    (lambda ()
  132.      (set-generic-record/cache!
  133.       record
  134.       (purge-cache-entries (generic-record/cache record)
  135.                (lambda (tags) (filter generic tags)))))))
  136.  
  137. (define (guarantee-generic-procedure generic caller)
  138.   (or (eqht/get generic-procedure-records generic #f)
  139.       (error:wrong-type-argument generic "generic procedure" caller)))
  140.  
  141. (define (guarantee-generator generator caller)
  142.   (if (not (or (not generator)
  143.            (and (procedure? generator)
  144.             (procedure-arity-valid? generator 2))))
  145.       (error:wrong-type-argument generator
  146.                  "generic procedure generator"
  147.                  caller)))
  148.  
  149. ;;;; Generic Procedure Application
  150.  
  151. (define (compute-apply-generic record)
  152.   (let ((arity (generic-record/arity record)))
  153.     (cond ((pair? arity) (apply-generic record))
  154.       ((= 1 arity) (apply-generic-1 record))
  155.       ((= 2 arity) (apply-generic-2 record))
  156.       ((= 3 arity) (apply-generic-3 record))
  157.       ((= 4 arity) (apply-generic-4 record))
  158.       (else (apply-generic record)))))
  159.  
  160. (define (apply-generic record)
  161.   (let ((min-arity (generic-record/min-arity record))
  162.     (max-arity (generic-record/max-arity record)))
  163.     (let ((extra (and max-arity (- max-arity min-arity))))
  164.       (letrec
  165.       ((generic
  166.         (lambda args
  167.           (let loop ((args* args) (n min-arity) (tags '()))
  168.         (if (fix:= n 0)
  169.             (begin
  170.               (if (and extra
  171.                    (let loop ((args* args*) (n extra))
  172.                  (and (not (null? args*))
  173.                       (or (fix:= n 0)
  174.                       (loop (cdr args*)
  175.                         (fix:- n 1))))))
  176.               (wna args))
  177.               (let ((procedure
  178.                  (probe-cache (generic-record/cache record) tags)))
  179.             (if procedure
  180.                 (apply procedure args)
  181.                 (compute-method-and-store record args))))
  182.             (begin
  183.               (if (null? args*)
  184.               (wna args))
  185.               (loop (cdr args*)
  186.                 (fix:- n 1)
  187.                 (cons (dispatch-tag (car args*)) tags)))))))
  188.        (wna
  189.         (lambda (args)
  190.           (error:wrong-number-of-arguments generic
  191.                            (generic-record/arity record)
  192.                            args))))
  193.     generic))))
  194.  
  195. (define (generic-procedure-applicable? procedure arguments)
  196.   (let ((record
  197.      (guarantee-generic-procedure procedure
  198.                       'GENERIC-PROCEDURE-APPLICABLE?))
  199.     (tags (map dispatch-tag arguments)))
  200.     (let ((generator (generic-record/generator record))
  201.       (arity (generic-record/arity record))
  202.       (n-args (length tags)))
  203.       (and generator
  204.        (if (pair? arity)
  205.            (let ((min-arity (arity-min arity))
  206.              (max-arity (arity-max arity)))
  207.          (if (fix:= n-args min-arity)
  208.              (generator procedure tags)
  209.              (and (fix:> n-args min-arity)
  210.               (or (not max-arity)
  211.                   (fix:<= n-args max-arity))
  212.               (generator procedure (list-head tags min-arity)))))
  213.            (and (fix:= arity n-args)
  214.             (generator procedure tags)))))))
  215.  
  216. (define (apply-generic-1 record)
  217.   (lambda (a1)
  218.     (declare (integrate-operator dispatch-tag))
  219.     (let ((procedure
  220.        (probe-cache-1 (generic-record/cache record)
  221.               (dispatch-tag a1))))
  222.       (if procedure
  223.       (procedure a1)
  224.       (compute-method-and-store record (list a1))))))
  225.  
  226. (define (apply-generic-2 record)
  227.   (lambda (a1 a2)
  228.     (declare (integrate-operator dispatch-tag))
  229.     (let ((procedure
  230.        (probe-cache-2 (generic-record/cache record)
  231.               (dispatch-tag a1)
  232.               (dispatch-tag a2))))
  233.       (if procedure
  234.       (procedure a1 a2)
  235.       (compute-method-and-store record (list a1 a2))))))
  236.  
  237. (define (apply-generic-3 record)
  238.   (lambda (a1 a2 a3)
  239.     (declare (integrate-operator dispatch-tag))
  240.     (let ((procedure
  241.        (probe-cache-3 (generic-record/cache record)
  242.               (dispatch-tag a1)
  243.               (dispatch-tag a2)
  244.               (dispatch-tag a3))))
  245.       (if procedure
  246.       (procedure a1 a2 a3)
  247.       (compute-method-and-store record (list a1 a2 a3))))))
  248.  
  249. (define (apply-generic-4 record)
  250.   (lambda (a1 a2 a3 a4)
  251.     (declare (integrate-operator dispatch-tag))
  252.     (let ((procedure
  253.        (probe-cache-4 (generic-record/cache record)
  254.               (dispatch-tag a1)
  255.               (dispatch-tag a2)
  256.               (dispatch-tag a3)
  257.               (dispatch-tag a4))))
  258.       (if procedure
  259.       (procedure a1 a2 a3 a4)
  260.       (compute-method-and-store record (list a1 a2 a3 a4))))))
  261.  
  262. (define (compute-method-and-store record args)
  263.   (let ((tags (map dispatch-tag args)))
  264.     (let ((procedure
  265.        (let ((generator (generic-record/generator record))
  266.          (generic (generic-record/procedure record)))
  267.          (or (and generator (generator generic tags))
  268.          (error:no-applicable-methods generic args)))))
  269.       (without-interrupts
  270.        (lambda ()
  271.      (set-generic-record/cache!
  272.       record
  273.       (fill-cache (generic-record/cache record) tags procedure))))
  274.       (apply procedure args))))
  275.  
  276. ;;;; Object Tags
  277.  
  278. ;;; We assume that most new data types will be constructed from tagged
  279. ;;; vectors, and therefore we should optimize the path for such
  280. ;;; structures as much as possible.
  281.  
  282. (define (dispatch-tag object)
  283.   (declare (integrate object))
  284.   (declare (ignore-reference-traps (set microcode-type-tag-table
  285.                     microcode-type-method-table)))
  286.   (if (and (%record? object)
  287.        (%record? (%record-ref object 0))
  288.        (eq? dispatch-tag-marker (%record-ref (%record-ref object 0) 0)))
  289.       (%record-ref object 0)
  290.       (or (vector-ref microcode-type-tag-table (object-type object))
  291.       ((vector-ref microcode-type-method-table (object-type object))
  292.        object))))
  293.  
  294. (define (make-built-in-tag name)
  295.   (let ((entry (assq name built-in-tag-table)))
  296.     (if entry
  297.     (cdr entry)
  298.     (let ((tag (make-dispatch-tag name)))
  299.       (set! built-in-tag-table (cons (cons name tag) built-in-tag-table))
  300.       tag))))
  301.  
  302. (define (built-in-dispatch-tags)
  303.   (map cdr built-in-tag-table))
  304.  
  305. (define (built-in-dispatch-tag name)
  306.   (let ((entry (assq name built-in-tag-table)))
  307.     (and entry
  308.      (cdr entry))))
  309.  
  310. (define condition-type:no-applicable-methods)
  311. (define error:no-applicable-methods)
  312.  
  313. (define (initialize-conditions!)
  314.   (set! condition-type:no-applicable-methods
  315.     (make-condition-type 'NO-APPLICABLE-METHODS condition-type:error
  316.         '(OPERATOR OPERANDS)
  317.       (lambda (condition port)
  318.         (write-string "No applicable methods for " port)
  319.         (write (access-condition condition 'OPERATOR) port)
  320.         (write-string " with these arguments: " port)
  321.         (write (access-condition condition 'OPERANDS) port)
  322.         (write-string "." port))))
  323.   (set! error:no-applicable-methods
  324.     (condition-signaller condition-type:no-applicable-methods
  325.                  '(OPERATOR OPERANDS)
  326.                  standard-error-handler))
  327.   unspecific)
  328.  
  329. ;;;; Initialization
  330.  
  331. (define standard-generic-procedure-tag)
  332. (define generic-procedure-records)
  333. (define built-in-tag-table)
  334. (define microcode-type-tag-table)
  335. (define microcode-type-method-table)
  336.  
  337. (define (initialize-generic-procedures!)
  338.   (set! standard-generic-procedure-tag
  339.     (make-dispatch-tag 'STANDARD-GENERIC-PROCEDURE))
  340.   (set! generic-procedure-records (make-eqht))
  341.  
  342.   ;; Initialize the built-in tag tables.
  343.   (set! built-in-tag-table '())
  344.   (set! microcode-type-tag-table
  345.     (make-initialized-vector (microcode-type/code-limit)
  346.       (lambda (code)
  347.         (make-built-in-tag
  348.          (or (microcode-type/code->name code) 'OBJECT)))))
  349.   (set! microcode-type-method-table
  350.     (make-vector (microcode-type/code-limit) #f))
  351.   (let ((assign-type
  352.      (lambda (name get-method)
  353.        (let ((code (microcode-type/name->code name)))
  354.          (vector-set! microcode-type-method-table code
  355.               (get-method
  356.                (vector-ref microcode-type-tag-table code)))
  357.          (vector-set! microcode-type-tag-table code #f)))))
  358.     (define-integrable (maybe-generic object default-tag)
  359.       (let ((record (eqht/get generic-procedure-records object #f)))
  360.     (if record
  361.         (generic-record/tag record)
  362.         default-tag)))
  363.     (let ((procedure-type
  364.        (lambda (default-tag)
  365.          (lambda (object)
  366.            (maybe-generic object default-tag)))))
  367.       (assign-type 'EXTENDED-PROCEDURE procedure-type)
  368.       (assign-type 'PROCEDURE procedure-type))
  369.     (assign-type
  370.      'COMPILED-ENTRY
  371.      (let ((procedure-tag (make-built-in-tag 'COMPILED-PROCEDURE))
  372.        (return-address-tag (make-built-in-tag 'COMPILED-RETURN-ADDRESS))
  373.        (expression-tag (make-built-in-tag 'COMPILED-EXPRESSION)))
  374.        (lambda (default-tag)
  375.      (lambda (object)
  376.        (case (system-hunk3-cxr0
  377.           ((ucode-primitive compiled-entry-kind 1) object))
  378.          ((0) (maybe-generic object procedure-tag))
  379.          ((1) return-address-tag)
  380.          ((2) expression-tag)
  381.          (else default-tag))))))
  382.     (let ((boolean-tag (make-built-in-tag 'BOOLEAN)))
  383.       (if (> microcode-id/version 11)
  384.       (assign-type 'CONSTANT
  385.                (lambda (default-tag)
  386.              (lambda (object)
  387.                (if (or (eq? #f object) (eq? #t object))
  388.                    boolean-tag
  389.                    default-tag))))
  390.       (begin
  391.         (assign-type 'FALSE
  392.              (lambda (default-tag)
  393.                (lambda (object)
  394.                  (if (eq? #f object)
  395.                  boolean-tag
  396.                  default-tag))))
  397.         (assign-type 'CONSTANT
  398.              (lambda (default-tag)
  399.                (lambda (object)
  400.                  (if (eq? #t object)
  401.                  boolean-tag
  402.                  default-tag)))))))
  403.     (assign-type 'FLONUM
  404.          (let ((flonum-vector-tag
  405.             (make-built-in-tag 'FLONUM-VECTOR)))
  406.            (lambda (default-tag)
  407.              (lambda (object)
  408.                (if (fix:= 2 (system-vector-length object))
  409.                default-tag
  410.                flonum-vector-tag)))))
  411.     (assign-type 'RECORD
  412.          (let ((dt-tag (make-built-in-tag 'DISPATCH-TAG)))
  413.            (lambda (default-tag)
  414.              (lambda (object)
  415.                (if (eq? dispatch-tag-marker (%record-ref object 0))
  416.                dt-tag
  417.                default-tag)))))))