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 / compiler / machines / vax / rules2.scm < prev    next >
Encoding:
Text File  |  1999-01-02  |  5.1 KB  |  144 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: rules2.scm,v 4.5 1999/01/02 06:06:43 cph Exp $
  4. $MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
  5.  
  6. Copyright (c) 1987, 1989, 1991, 1999 Massachusetts Institute of Technology
  7.  
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or (at
  11. your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful, but
  14. WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16. General Public License for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21. |#
  22.  
  23. ;;;; LAP Generation Rules: Predicates.
  24. ;;; Note: All fixnum code is in rulfix.scm.
  25. ;;; package: (compiler lap-syntaxer)
  26.  
  27. (declare (usual-integrations))
  28.  
  29. (define-rule predicate
  30.   (TYPE-TEST (REGISTER (? register)) (? type))
  31.   (set-standard-branches! 'EQL)
  32.   (test-byte type (reference-alias-register! register 'GENERAL)))
  33.  
  34. (define-rule predicate
  35.   (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
  36.   (compare-type type (any-register-reference register)))
  37.  
  38. (define-rule predicate
  39.   (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
  40.          (? type))
  41.   (compare-type type (indirect-reference! address offset)))
  42.  
  43. (define-rule predicate
  44.   (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
  45.   (compare/register*register register-1 register-2 'EQL))
  46.  
  47. (define-rule predicate
  48.   (EQ-TEST (REGISTER (? register)) (? memory))
  49.   (QUALIFIER (predicate/memory-operand? memory))
  50.   (compare/register*memory register
  51.                (predicate/memory-operand-reference memory)
  52.                'EQL))
  53.  
  54. (define-rule predicate
  55.   (EQ-TEST (? memory) (REGISTER (? register)))
  56.   (QUALIFIER (predicate/memory-operand? memory))
  57.   (compare/register*memory register
  58.                (predicate/memory-operand-reference memory)
  59.                'EQL))
  60.  
  61. (define-rule predicate
  62.   (EQ-TEST (? memory-1) (? memory-2))
  63.   (QUALIFIER (and (predicate/memory-operand? memory-1)
  64.           (predicate/memory-operand? memory-2)))
  65.   (compare/memory*memory (predicate/memory-operand-reference memory-1)
  66.              (predicate/memory-operand-reference memory-2)
  67.              'EQL))
  68.  
  69. (define-rule predicate
  70.   (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
  71.   (eq-test/constant*register constant register))
  72.  
  73. (define-rule predicate
  74.   (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
  75.   (eq-test/constant*register constant register))
  76.  
  77. (define-rule predicate
  78.   (EQ-TEST (CONSTANT (? constant)) (? memory))
  79.   (QUALIFIER (predicate/memory-operand? memory))
  80.   (eq-test/constant*memory constant memory))
  81.  
  82. (define-rule predicate
  83.   (EQ-TEST (? memory) (CONSTANT (? constant)))
  84.   (QUALIFIER (predicate/memory-operand? memory))
  85.   (eq-test/constant*memory constant memory))
  86.  
  87. (define-rule predicate
  88.   (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
  89.              (MACHINE-CONSTANT (? datum)))
  90.        (REGISTER (? register)))
  91.   (eq-test/synthesized-constant*register type datum register))
  92.  
  93. (define-rule predicate
  94.   (EQ-TEST (REGISTER (? register))
  95.        (CONS-POINTER (MACHINE-CONSTANT (? type))
  96.              (MACHINE-CONSTANT (? datum))))
  97.   (eq-test/synthesized-constant*register type datum register))
  98.  
  99. (define-rule predicate
  100.   (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
  101.              (MACHINE-CONSTANT (? datum)))
  102.        (? memory))
  103.   (QUALIFIER (predicate/memory-operand? memory))
  104.   (eq-test/synthesized-constant*memory type datum memory))
  105.  
  106. (define-rule predicate
  107.   (EQ-TEST (? memory)
  108.        (CONS-POINTER (MACHINE-CONSTANT (? type))
  109.              (MACHINE-CONSTANT (? datum))))
  110.   (QUALIFIER (predicate/memory-operand? memory))
  111.   (eq-test/synthesized-constant*memory type datum memory))
  112.  
  113. ;;;; Utilities
  114.  
  115. (define (eq-test/synthesized-constant type datum ea)
  116.   (set-standard-branches! 'EQL)
  117.   (test-non-pointer type datum ea))
  118.  
  119. (define-integrable (eq-test/synthesized-constant*register type datum reg)
  120.   (eq-test/synthesized-constant type datum
  121.                 (any-register-reference reg)))
  122.  
  123. (define-integrable (eq-test/synthesized-constant*memory type datum memory)
  124.   (eq-test/synthesized-constant type datum
  125.                 (predicate/memory-operand-reference memory)))
  126.  
  127. (define (eq-test/constant*register constant register)
  128.   (if (non-pointer-object? constant)
  129.       (eq-test/synthesized-constant (object-type constant)
  130.                     (careful-object-datum constant)
  131.                     (any-register-reference register))
  132.       (compare/register*memory register
  133.                    (INST-EA (@PCR ,(constant->label constant)))
  134.                    'EQL)))
  135.  
  136. (define (eq-test/constant*memory constant memory)
  137.   (let ((memory (predicate/memory-operand-reference memory)))
  138.     (if (non-pointer-object? constant)
  139.     (eq-test/synthesized-constant (object-type constant)
  140.                       (careful-object-datum constant)
  141.                       memory)
  142.     (compare/memory*memory memory
  143.                    (INST-EA (@PCR ,(constant->label constant)))
  144.                    'EQL))))