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 / scomb.scm < prev    next >
Text File  |  1999-01-02  |  11KB  |  352 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: scomb.scm,v 14.16 1999/01/02 06:19:10 cph Exp $
  4.  
  5. Copyright (c) 1988-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. ;;;; SCode Combinator Abstractions
  23. ;;; package: (runtime scode-combinator)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! combination/constant-folding-operators
  29.     (map make-primitive-procedure
  30.          '(
  31.            &*
  32.            &+
  33.            &-
  34.            &/
  35.            -1+
  36.            1+
  37.            ASCII->CHAR
  38.            CELL?
  39.            CHAR->ASCII
  40.            CHAR->INTEGER
  41.            CHAR-ASCII?
  42.            CHAR-BITS
  43.            CHAR-CODE
  44.            CHAR-DOWNCASE
  45.            CHAR-UPCASE
  46.            COMPILED-CODE-ADDRESS->BLOCK
  47.            COMPILED-CODE-ADDRESS->OFFSET
  48.            DIVIDE-FIXNUM
  49.            EQ?
  50.            EQUAL-FIXNUM?
  51.            FIXNUM-AND
  52.            FIXNUM-ANDC
  53.            FIXNUM-LSH
  54.            FIXNUM-NOT
  55.            FIXNUM-OR
  56.            FIXNUM-QUOTIENT
  57.            FIXNUM-REMAINDER
  58.            FIXNUM-XOR
  59.            FLONUM-ABS
  60.            FLONUM-ACOS
  61.            FLONUM-ADD
  62.            FLONUM-ASIN
  63.            FLONUM-ATAN
  64.            FLONUM-ATAN2
  65.            FLONUM-CEILING
  66.            FLONUM-CEILING->EXACT
  67.            FLONUM-COS
  68.            FLONUM-DIVIDE
  69.            FLONUM-EQUAL?
  70.            FLONUM-EXP
  71.            FLONUM-EXPT
  72.            FLONUM-FLOOR
  73.            FLONUM-FLOOR->EXACT
  74.            FLONUM-GREATER?
  75.            FLONUM-LESS?
  76.            FLONUM-LOG
  77.            FLONUM-MULTIPLY
  78.            FLONUM-NEGATE
  79.            FLONUM-NEGATIVE?
  80.            FLONUM-POSITIVE?
  81.            FLONUM-ROUND
  82.            FLONUM-ROUND->EXACT
  83.            FLONUM-SIN
  84.            FLONUM-SQRT
  85.            FLONUM-SUBTRACT
  86.            FLONUM-TAN
  87.            FLONUM-TRUNCATE
  88.            FLONUM-TRUNCATE->EXACT
  89.            FLONUM-ZERO?
  90.            GCD-FIXNUM
  91.            GREATER-THAN-FIXNUM?
  92.            INDEX-FIXNUM?
  93.            INTEGER->CHAR
  94.            LESS-THAN-FIXNUM?
  95.            MAKE-CHAR
  96.            MAKE-NON-POINTER-OBJECT
  97.            MINUS-FIXNUM
  98.            MINUS-ONE-PLUS-FIXNUM
  99.            MULTIPLY-FIXNUM
  100.            NEGATIVE-FIXNUM?
  101.            NEGATIVE?
  102.            NOT
  103.            OBJECT-TYPE
  104.            OBJECT-TYPE?
  105.            ONE-PLUS-FIXNUM
  106.            PAIR?
  107.            PLUS-FIXNUM
  108.            POSITIVE-FIXNUM?
  109.            POSITIVE?
  110.            PRIMITIVE-PROCEDURE-ARITY
  111.            ;; STRING->SYMBOL is a special case.  Strings have can
  112.            ;; be side-effected, but it is useful to be able to
  113.            ;; constant fold this primitive anyway.
  114.            STRING->SYMBOL
  115.            ZERO-FIXNUM?
  116.            ZERO?
  117.            ))))
  118.  
  119. ;;;; Sequence
  120.  
  121. (define (make-sequence actions)
  122.   (if (null? actions)
  123.       (error "MAKE-SEQUENCE: No actions"))
  124.   (let loop ((actions actions))
  125.     (cond ((null? (cdr actions))
  126.        (car actions))
  127.       ((null? (cddr actions))
  128.        (&typed-pair-cons (ucode-type sequence-2)
  129.                  (car actions)
  130.                  (cadr actions)))
  131.       (else
  132.        (&typed-triple-cons (ucode-type sequence-3)
  133.                    (car actions)
  134.                    (cadr actions)
  135.                    (loop (cddr actions)))))))
  136.  
  137. (define (sequence? object)
  138.   (or (object-type? (ucode-type sequence-2) object)
  139.       (object-type? (ucode-type sequence-3) object)))
  140.  
  141. (define (sequence-actions expression)
  142.   (cond ((object-type? (ucode-type sequence-2) expression)
  143.      (append! (sequence-actions (&pair-car expression))
  144.           (sequence-actions (&pair-cdr expression))))
  145.     ((object-type? (ucode-type sequence-3) expression)
  146.      (append! (sequence-actions (&triple-first expression))
  147.           (sequence-actions (&triple-second expression))
  148.           (sequence-actions (&triple-third expression))))
  149.     (else
  150.      (list expression))))
  151.  
  152. (define (sequence-immediate-actions expression)
  153.   (cond ((object-type? (ucode-type sequence-2) expression)
  154.      (list (&pair-car expression)
  155.            (&pair-cdr expression)))
  156.     ((object-type? (ucode-type sequence-3) expression)
  157.      (list (&triple-first expression)
  158.            (&triple-second expression)
  159.            (&triple-third expression)))
  160.     (else
  161.      (error:wrong-type-argument expression "SCode sequence"
  162.                     'SEQUENCE-IMMEDIATE-ACTIONS))))
  163.  
  164. (define-integrable (sequence-components expression receiver)
  165.   (receiver (sequence-actions expression)))
  166.  
  167. ;;;; Conditional
  168.  
  169. (define (make-conditional predicate consequent #!optional alternative)
  170.   (let ((alternative
  171.      (if (default-object? alternative)
  172.          undefined-conditional-branch
  173.          alternative)))
  174.     (if (and (combination? predicate)
  175.          (eq? (combination-operator predicate) (ucode-primitive not)))
  176.     (make-conditional (car (combination-operands predicate))
  177.               alternative
  178.               consequent)
  179.     (&typed-triple-cons (ucode-type conditional)
  180.                 predicate
  181.                 consequent
  182.                 alternative))))
  183.  
  184. (define (conditional? object)
  185.   (object-type? (ucode-type conditional) object))
  186.  
  187. (define undefined-conditional-branch unspecific)
  188.  
  189. (define-integrable (conditional-predicate conditional)
  190.   (&triple-first conditional))
  191.  
  192. (define-integrable (conditional-consequent conditional)
  193.   (&triple-second conditional))
  194.  
  195. (define-integrable (conditional-alternative conditional)
  196.   (&triple-third conditional))
  197.  
  198. (define (conditional-components conditional receiver)
  199.   (receiver (conditional-predicate conditional)
  200.         (conditional-consequent conditional)
  201.         (conditional-alternative conditional)))
  202.  
  203. ;;;; Disjunction
  204.  
  205. (define (make-disjunction predicate alternative)
  206.   (if (and (combination? predicate)
  207.        (eq? (combination-operator predicate) (ucode-primitive not)))
  208.       (make-conditional (car (combination-operands predicate))
  209.             alternative
  210.             true)
  211.       (&typed-pair-cons (ucode-type disjunction) predicate alternative)))
  212.  
  213. (define-integrable (disjunction? object)
  214.   (object-type? (ucode-type disjunction) object))
  215.  
  216. (define-integrable (disjunction-predicate disjunction)
  217.   (&pair-car disjunction))
  218.  
  219. (define-integrable (disjunction-alternative disjunction)
  220.   (&pair-cdr disjunction))
  221.  
  222. (define (disjunction-components disjunction receiver)
  223.   (receiver (disjunction-predicate disjunction)
  224.         (disjunction-alternative disjunction)))
  225.  
  226. ;;;; Combination
  227.  
  228. (define (combination? object)
  229.   (or (object-type? (ucode-type combination) object)
  230.       (object-type? (ucode-type combination-1) object)
  231.       (object-type? (ucode-type combination-2) object)
  232.       (object-type? (ucode-type primitive-combination-0) object)
  233.       (object-type? (ucode-type primitive-combination-1) object)
  234.       (object-type? (ucode-type primitive-combination-2) object)
  235.       (object-type? (ucode-type primitive-combination-3) object)))
  236.  
  237. (define (make-combination operator operands)
  238.   (if (and (memq operator combination/constant-folding-operators)
  239.        (let loop ((operands operands))
  240.          (or (null? operands)
  241.          (and (scode-constant? (car operands))
  242.               (loop (cdr operands))))))
  243.       (apply operator operands)
  244.       (%make-combination operator operands)))
  245.  
  246. (define combination/constant-folding-operators)
  247.  
  248. (define (%make-combination operator operands)
  249.   (cond ((null? operands)
  250.      (if (and (primitive-procedure? operator)
  251.           (= (primitive-procedure-arity operator) 0))
  252.          (object-new-type (ucode-type primitive-combination-0) operator)
  253.          (&typed-vector-cons (ucode-type combination)
  254.                  (cons operator '()))))
  255.     ((null? (cdr operands))
  256.      (&typed-pair-cons
  257.       (if (and (primitive-procedure? operator)
  258.            (= (primitive-procedure-arity operator) 1))
  259.           (ucode-type primitive-combination-1)
  260.           (ucode-type combination-1))
  261.       operator
  262.       (car operands)))
  263.     ((null? (cddr operands))
  264.      (&typed-triple-cons
  265.       (if (and (primitive-procedure? operator)
  266.            (= (primitive-procedure-arity operator) 2))
  267.           (ucode-type primitive-combination-2)
  268.           (ucode-type combination-2))
  269.       operator
  270.       (car operands)
  271.       (cadr operands)))
  272.     (else
  273.      (&typed-vector-cons
  274.       (if (and (null? (cdddr operands))
  275.            (primitive-procedure? operator)
  276.            (= (primitive-procedure-arity operator) 3))
  277.           (ucode-type primitive-combination-3)
  278.           (ucode-type combination))
  279.       (cons operator operands)))))
  280.  
  281. (let-syntax
  282.     ((combination-dispatch
  283.       (macro (name combination case-0 case-1 case-2 case-n)
  284.     `(COND ((OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-0)
  285.                   ,combination)
  286.         ,case-0)
  287.            ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-1) ,combination)
  288.             (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-1)
  289.                   ,combination))
  290.         ,case-1)
  291.            ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION-2) ,combination)
  292.             (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-2)
  293.                   ,combination))
  294.         ,case-2)
  295.            ((OR (OBJECT-TYPE? (UCODE-TYPE COMBINATION) ,combination)
  296.             (OBJECT-TYPE? (UCODE-TYPE PRIMITIVE-COMBINATION-3)
  297.                   ,combination))
  298.         ,case-n)
  299.            (ELSE
  300.         (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination"
  301.                        ',name))))))
  302.  
  303. (define (combination-size combination)
  304.   (combination-dispatch combination-size combination
  305.             1 2 3 (&vector-length combination)))
  306.  
  307. (define (combination-operator combination)
  308.   (combination-dispatch combination-operator combination
  309.             (object-new-type (ucode-type primitive) combination)
  310.             (&pair-car combination)
  311.             (&triple-first combination)
  312.             (&vector-ref combination 0)))
  313.  
  314. (define (combination-operands combination)
  315.   (combination-dispatch
  316.    combination-operands combination
  317.    '()
  318.    (list (&pair-cdr combination))
  319.    (list (&triple-second combination) (&triple-third combination))
  320.    (&subvector->list combination 1 (&vector-length combination))))
  321.  
  322. (define (combination-components combination receiver)
  323.   (combination-dispatch
  324.    combination-components combination
  325.    (receiver (object-new-type (ucode-type primitive) combination) '())
  326.    (receiver (&pair-car combination) (list (&pair-cdr combination)))
  327.    (receiver (&triple-first combination)
  328.          (list (&triple-second combination) (&triple-third combination)))
  329.    (receiver (&vector-ref combination 0)
  330.          (&subvector->list combination 1 (&vector-length combination)))))
  331.  
  332. )
  333.  
  334. ;;;; Unassigned?
  335.  
  336. (define (make-unassigned? name)
  337.   (make-combination (ucode-primitive lexical-unassigned?)
  338.             (list (make-the-environment) name)))
  339.  
  340. (define (unassigned?? object)
  341.   (and (combination? object)
  342.        (eq? (combination-operator object)
  343.         (ucode-primitive lexical-unassigned?))
  344.        (let ((operands (combination-operands object)))
  345.      (and (the-environment? (car operands))
  346.           (symbol? (cadr operands))))))
  347.  
  348. (define-integrable (unassigned?-name expression)
  349.   (cadr (combination-operands expression)))
  350.  
  351. (define-integrable (unassigned?-components expression receiver)
  352.   (receiver (unassigned?-name expression)))