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 / uproc.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  325 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: uproc.scm,v 1.11 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1990-1999 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. ;;;; Microcode Procedures
  23. ;;; package: (runtime procedure)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Generic Procedures
  28.  
  29. (define (procedure? object)
  30.   (let ((object (skip-entities object)))
  31.     (or (%compound-procedure? object)
  32.     (%primitive-procedure? object)
  33.     (%compiled-procedure? object))))
  34.  
  35. (define (procedure-lambda procedure)
  36.   (discriminate-procedure procedure
  37.               (lambda (procedure) procedure false)
  38.               %compound-procedure-lambda
  39.               compiled-procedure/lambda))
  40.  
  41. (define (procedure-environment procedure)
  42.   (discriminate-procedure
  43.    procedure
  44.    (lambda (procedure)
  45.      (error "primitive procedures have no closing environment" procedure))
  46.    %compound-procedure-environment
  47.    compiled-procedure/environment))
  48.  
  49. (define (procedure-components procedure receiver)
  50.   (discriminate-procedure
  51.    procedure
  52.    (lambda (procedure)
  53.      (error "primitive procedures have no components" procedure))
  54.    (lambda (procedure)
  55.      (receiver (%compound-procedure-lambda procedure)
  56.            (%compound-procedure-environment procedure)))
  57.    (lambda (procedure)
  58.      (receiver (compiled-procedure/lambda procedure)
  59.            (compiled-procedure/environment procedure)))))
  60.  
  61. (define (discriminate-procedure procedure if-primitive if-compound if-compiled)
  62.   (let ((procedure* (skip-entities procedure)))
  63.     (cond ((%primitive-procedure? procedure*) (if-primitive procedure*))
  64.       ((%compound-procedure? procedure*) (if-compound procedure*))
  65.       ((%compiled-procedure? procedure*) (if-compiled procedure*))
  66.       (else (error:wrong-type-argument procedure "procedure" #F)))))
  67.  
  68. (define (skip-entities object)
  69.   (if (%entity? object)
  70.       (skip-entities (if (%entity-is-apply-hook? object)
  71.              (apply-hook-procedure object)
  72.              (entity-procedure object)))
  73.       object))
  74.  
  75. (define (procedure-arity procedure)
  76.   (let loop ((p procedure) (e 0))
  77.     (cond ((%primitive-procedure? p)
  78.        (let ((arity (primitive-procedure-arity p)))
  79.          (cond ((negative? arity)
  80.             (cons 0 false))
  81.            ((<= e arity)
  82.             (let ((arity (- arity e)))
  83.               (cons arity arity)))
  84.            (else
  85.             (error "illegal arity for entity" procedure)))))
  86.       ((%compound-procedure? p)
  87.        (lambda-components (%compound-procedure-lambda p)
  88.          (lambda (name required optional rest auxiliary decl body)
  89.            name auxiliary decl body
  90.            (let ((r (- (length required) e)))
  91.          (cond (rest
  92.             (cons (if (negative? r) 0 r) false))
  93.                ((not (negative? r))
  94.             (cons r (+ r (length optional))))
  95.                (else
  96.             (error "illegal arity for entity" procedure)))))))
  97.       ((%compiled-procedure? p)
  98.        (let ((info (compiled-entry-kind p))
  99.          (e+1 (1+ e)))
  100.          ;; max = (-1)^tail? * (1 + req + opt + tail?)
  101.          ;; min = (1 + req)
  102.          (let ((min (- (system-hunk3-cxr1 info) e+1))
  103.            (max (system-hunk3-cxr2 info)))
  104.            (cond ((negative? max)
  105.               (cons (if (negative? min) 0 min) false))
  106.              ((not (negative? min))
  107.               (cons min (- max e+1)))
  108.              (else
  109.               (error "illegal arity for entity" procedure))))))
  110.       ((%entity? p)
  111.        (if (%entity-is-apply-hook? p)
  112.            (loop (apply-hook-procedure p) e)
  113.            (loop (entity-procedure p) (1+ e))))
  114.       (else
  115.        (error:wrong-type-argument procedure "procedure"
  116.                       'PROCEDURE-ARITY)))))
  117.  
  118. (define (procedure-arity-valid? procedure n-arguments)
  119.   (let ((arity (procedure-arity procedure)))
  120.     (and (<= (car arity) n-arguments)
  121.      (if (cdr arity)
  122.          (<= n-arguments (cdr arity))
  123.          true))))
  124.  
  125. ;;;; Interpreted Procedures
  126.  
  127. (define-integrable (%primitive-procedure? object)
  128.   (object-type? (ucode-type primitive) object))
  129.  
  130. (define-integrable (%primitive-procedure-name procedure)
  131.   (intern ((ucode-primitive get-primitive-name) procedure)))
  132.  
  133. (define-integrable (%primitive-procedure-implemented? procedure)
  134.   ((ucode-primitive get-primitive-address)
  135.    (%primitive-procedure-name procedure)
  136.    false))
  137.  
  138. (define (primitive-procedure? object)
  139.   (%primitive-procedure? (skip-entities object)))
  140.  
  141. (define (make-primitive-procedure name #!optional arity)
  142.   (let ((arity (if (default-object? arity) false arity)))
  143.     (let ((result ((ucode-primitive get-primitive-address) name arity)))
  144.       (if (not (or (object-type? (ucode-type primitive) result)
  145.            (eq? arity true)))
  146.       (if (false? result)
  147.           (error "MAKE-PRIMITIVE-PROCEDURE: unknown name" name)
  148.           (error "MAKE-PRIMITIVE-PROCEDURE: inconsistent arity" name
  149.              (error-irritant/noise " new:") arity
  150.              (error-irritant/noise " old:") result)))
  151.       result)))
  152.  
  153. (define (primitive-procedure-name procedure)
  154.   (%primitive-procedure-name (%primitive-procedure-arg procedure)))
  155.  
  156. (define (implemented-primitive-procedure? procedure)
  157.   (%primitive-procedure-implemented? (%primitive-procedure-arg procedure)))
  158.  
  159. (define (%primitive-procedure-arg procedure)
  160.   (let ((procedure* (skip-entities procedure)))
  161.     (if (not (%primitive-procedure? procedure*))
  162.     (error:wrong-type-datum  procedure "primitive procedure"))
  163.     procedure*))
  164.  
  165. (define-integrable (%compound-procedure? object)
  166.   (or (object-type? (ucode-type procedure) object)
  167.       (object-type? (ucode-type extended-procedure) object)))
  168.  
  169. (define-integrable (%compound-procedure-lambda procedure)
  170.   (system-pair-car procedure))
  171.  
  172. (define-integrable (%compound-procedure-environment procedure)
  173.   (system-pair-cdr procedure))
  174.  
  175. (define (compound-procedure? object)
  176.   (let ((object (skip-entities object)))
  177.     (%compound-procedure? object)))
  178.  
  179. ;;;; Compiled Procedures
  180.  
  181. (define-integrable (%compiled-procedure? object)
  182.   (and (object-type? (ucode-type compiled-entry) object)
  183.        (eq? 0 (system-hunk3-cxr0 (compiled-entry-kind object)))))
  184.  
  185. (define-integrable compiled-entry-kind
  186.   (ucode-primitive compiled-entry-kind 1))
  187.  
  188. (define (compiled-procedure? object)
  189.   (let ((object (skip-entities object)))
  190.     (%compiled-procedure? object)))
  191.  
  192. (define (compiled-procedure-frame-size procedure)
  193.   (let loop ((p procedure))
  194.     (cond ((%compiled-procedure? p)
  195.        (let ((max (system-hunk3-cxr2 (compiled-entry-kind p))))
  196.          ;; max = (-1)^tail? * (1 + req + opt + tail?)
  197.          ;; frame = req + opt + tail?
  198.          (if (negative? max)
  199.          (- -1 max)
  200.          (-1+ max))))
  201.       ((%entity? p)
  202.        (if (%entity-is-apply-hook? p)
  203.            (loop (apply-hook-procedure p))
  204.            (1+ (loop (entity-procedure p)))))
  205.       (else
  206.        (error:wrong-type-argument procedure "compiled procedure"
  207.                       'COMPILED-PROCEDURE-FRAME-SIZE)))))
  208.  
  209. (define (%compiled-closure? object)
  210.   (and (%compiled-procedure? object)
  211.        (compiled-code-block/manifest-closure?
  212.     (compiled-code-address->block object))))
  213.  
  214. (define %compiled-closure->entry
  215.   (ucode-primitive compiled-closure->entry 1))
  216.  
  217. (define (compiled-closure? object)
  218.   (let ((object (skip-entities object)))
  219.     (%compiled-closure? object)))
  220.  
  221. (define (compiled-closure->entry closure)
  222.   (%compiled-closure->entry
  223.    (let ((closure* (skip-entities closure)))
  224.      (if (not (%compiled-closure? closure*))
  225.      (error:wrong-type-argument closure "compiled closure"
  226.                     'COMPILED-CLOSURE->ENTRY))
  227.      closure*)))
  228.  
  229. ;; In the following two procedures, offset can be #f to support
  230. ;; old-style 68020 closures.  When offset is not #f, it works on all
  231. ;; architectures.
  232.  
  233. (define (compiled-closure/ref closure index offset)
  234.   (if (not offset)
  235.       ((ucode-primitive primitive-object-ref 2) closure (+ 2 index))
  236.       ((ucode-primitive primitive-object-ref 2)
  237.        (if (compiled-closure? closure)
  238.        ((ucode-primitive compiled-code-address->block 1) closure)
  239.        ;; Closure may also be a vector in this case.
  240.        closure)
  241.        (+ index offset))))
  242.  
  243. (define-integrable (compiled-closure/set! closure index offset value)
  244.   (if (not offset)
  245.       ((ucode-primitive primitive-object-set! 3) closure (+ 2 index) value)
  246.       ((ucode-primitive primitive-object-set! 3)
  247.        ((ucode-primitive compiled-code-address->block 1)
  248.     closure)
  249.        (+ index offset)
  250.        value))
  251.   unspecific)
  252.  
  253. ;;;; Entities and Apply Hooks
  254.  
  255. (define-integrable (make-entity procedure extra)
  256.   (system-pair-cons (ucode-type entity) procedure extra))
  257.  
  258. (define-integrable (%entity? object)
  259.   (object-type? (ucode-type entity) object))
  260.  
  261. (define (entity? object)
  262.   (and (%entity? object)
  263.        (not (%entity-is-apply-hook? object))))
  264.  
  265. (define-integrable (entity-procedure entity)
  266.   (system-pair-car entity))
  267.  
  268. (define-integrable (entity-extra entity)
  269.   (system-pair-cdr entity))
  270.  
  271. (define-integrable (set-entity-procedure! entity procedure)
  272.   (system-pair-set-car! entity procedure))
  273.  
  274. (define-integrable (set-entity-extra! entity extra)
  275.   (system-pair-set-cdr! entity extra))
  276.  
  277. (define (make-apply-hook procedure extra)
  278.   (make-entity (lambda (entity . args)
  279.          (apply (apply-hook-procedure entity) args))
  280.            (hunk3-cons apply-hook-tag procedure extra)))
  281.  
  282. (define (apply-hook? object)
  283.   (and (%entity? object)
  284.        (%entity-is-apply-hook? object)))
  285.  
  286. (define-integrable (%entity-is-apply-hook? object)
  287.   (%entity-extra/apply-hook? (entity-extra object)))
  288.  
  289. (define (%entity-extra/apply-hook? extra)
  290.   ;; Ziggy cares about this one.
  291.   (and (object-type? (ucode-type hunk3) extra)
  292.        (eq? apply-hook-tag (system-hunk3-cxr0 extra))))
  293.  
  294. (define apply-hook-tag
  295.   "apply-hook-tag")
  296.  
  297. (define-integrable (apply-hook-procedure apply-hook)
  298.   (system-hunk3-cxr1 (entity-extra apply-hook)))
  299.  
  300. (define-integrable (apply-hook-extra apply-hook)
  301.   (system-hunk3-cxr2 (entity-extra apply-hook)))
  302.  
  303. (define-integrable (set-apply-hook-procedure! apply-hook procedure)
  304.   (system-hunk3-set-cxr1! (entity-extra apply-hook) procedure))
  305.  
  306. (define-integrable (set-apply-hook-extra! apply-hook procedure)
  307.   (system-hunk3-set-cxr2! (entity-extra apply-hook) procedure))
  308.  
  309. ;;;; Arity dispatched entities
  310.  
  311. (define (make-arity-dispatched-procedure default . dispatched-cases)
  312.   ;; DISPATCHED-CASES are the procedures to invoke for 0, 1, 2 etc
  313.   ;; arguments, or #F if the DEFAULT is to be used.  The DEFAULT has a
  314.   ;; SELF argument.
  315.   (make-entity default
  316.            (list->vector
  317.         (cons (fixed-objects-item 'ARITY-DISPATCHER-TAG)
  318.               dispatched-cases))))
  319.  
  320. (define (arity-dispatched-procedure? object)
  321.   (and (%entity? object)
  322.        (vector? (entity-extra object))
  323.        (< 0 (vector-length (entity-extra object)))
  324.        (eq? (vector-ref (entity-extra object) 0)
  325.         (fixed-objects-item 'ARITY-DISPATCHER-TAG))))