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 / base / utils.scm < prev   
Text File  |  1999-01-02  |  13KB  |  366 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: utils.scm,v 4.20 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1987-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. ;;;; Compiler Utilities
  23. ;; package: (compiler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Miscellaneous
  28.  
  29. (define (three-way-sort = set set* receiver)
  30.   (let ((member? (member-procedure =)))
  31.     (define (loop set set* receiver)
  32.       (if (null? set)
  33.       (receiver '() '() set*)
  34.       (let ((item (member? (car set) set*)))
  35.         (if item
  36.         (loop (cdr set) (delq! (car item) set*)
  37.           (lambda (set-only both set*-only)
  38.             (receiver set-only
  39.                   (cons (cons (car set) (car item)) both)
  40.                   set*-only)))
  41.         (loop (cdr set) set*
  42.           (lambda (set-only both set*-only)
  43.             (receiver (cons (car set) set-only)
  44.                   both
  45.                   set*-only)))))))
  46.     (loop set (list-copy set*) receiver)))
  47.  
  48. (define (discriminate-items items predicate)
  49.   (let loop ((items items) (passed '()) (failed '()))
  50.     (cond ((null? items)
  51.        (values (reverse! passed) (reverse! failed)))
  52.       ((predicate (car items))
  53.        (loop (cdr items) (cons (car items) passed) failed))
  54.       (else
  55.        (loop (cdr items) passed (cons (car items) failed))))))
  56.  
  57. (define (generate-label #!optional prefix)
  58.   (if (default-object? prefix) (set! prefix 'LABEL))
  59.   (string->uninterned-symbol
  60.    (canonicalize-label-name
  61.     (string-append
  62.      (symbol->string
  63.       (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA)
  64.         ((eq? prefix lambda-tag:let) 'LET)
  65.         ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT)
  66.         ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET)
  67.         (else prefix)))
  68.      "-"
  69.      (number->string (generate-label-number))))))
  70.  
  71. (define *current-label-number*)
  72.  
  73. (define (generate-label-number)
  74.   (let ((number *current-label-number*))
  75.     (set! *current-label-number* (1+ *current-label-number*))
  76.     number))
  77.  
  78. (define (list-filter-indices items indices)
  79.   (let loop ((items items) (indices indices) (index 0))
  80.     (cond ((null? indices) '())
  81.       ((= (car indices) index)
  82.        (cons (car items)
  83.          (loop (cdr items) (cdr indices) (1+ index))))
  84.       (else
  85.        (loop (cdr items) indices (1+ index))))))
  86.  
  87. (define (all-eq? items)
  88.   (if (null? items)
  89.       (error "ALL-EQ?: undefined for empty set"))
  90.   (or (null? (cdr items))
  91.       (for-all? (cdr items)
  92.     (let ((item (car items)))
  93.       (lambda (item*)
  94.         (eq? item item*))))))
  95.  
  96. (define (all-eq-map? items map)
  97.   (if (null? items)
  98.       (error "ALL-EQ-MAP?: undefined for empty set"))
  99.   (let ((item (map (car items))))
  100.     (if (or (null? (cdr items))
  101.         (for-all? (cdr items) (lambda (item*) (eq? item (map item*)))))
  102.     (values true item)
  103.     (values false false))))
  104.  
  105. (define (eq-set-union* set sets)
  106.   (let loop ((set set) (sets sets) (accum '()))
  107.     (if (null? sets)
  108.     (eq-set-union set accum)
  109.     (loop (car sets) (cdr sets) (eq-set-union set accum)))))
  110.  
  111. (package (transitive-closure enqueue-node! enqueue-nodes!)
  112.  
  113. (define *queue*)
  114.  
  115. (define-export (transitive-closure initialization process-node nodes)
  116.   (fluid-let ((*queue* true))
  117.     (if initialization (initialization))
  118.     (set! *queue* nodes)
  119.     (let loop ()
  120.       (if (not (null? *queue*))
  121.       (begin (let ((node (car *queue*)))
  122.            (set! *queue* (cdr *queue*))
  123.            (process-node node))
  124.          (loop))))))
  125.  
  126. (define-export (enqueue-node! node)
  127.   (if (and (not (eq? *queue* true))
  128.        (not (memq node *queue*)))
  129.       (set! *queue* (cons node *queue*))))
  130.  
  131. (define-export (enqueue-nodes! nodes)
  132.   (if (not (eq? *queue* true))
  133.       (set! *queue* (eq-set-union nodes *queue*))))
  134.  
  135. )
  136.  
  137. ;;;; Type Codes
  138.  
  139. (let-syntax ((define-type-code
  140.            (macro (var-name #!optional type-name)
  141.          (if (default-object? type-name) (set! type-name var-name))
  142.          `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name)
  143.             ',(microcode-type type-name)))))
  144.   (define-type-code lambda)
  145.   (define-type-code extended-lambda)
  146.   (define-type-code procedure)
  147.   (define-type-code extended-procedure)
  148.   (define-type-code cell)
  149.   (define-type-code environment)
  150.   (define-type-code unassigned)
  151.   (define-type-code stack-environment)
  152.   (define-type-code compiled-entry))
  153.  
  154. (define (scode/procedure-type-code *lambda)
  155.   (cond ((object-type? type-code:lambda *lambda)
  156.      type-code:procedure)
  157.     ((object-type? type-code:extended-lambda *lambda)
  158.      type-code:extended-procedure)
  159.     (else
  160.      (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
  161.  
  162. ;;; Primitive Procedures
  163.  
  164. (define (primitive-procedure? object)
  165.   (or (eq? compiled-error-procedure object)
  166.       (scode/primitive-procedure? object)))
  167.  
  168. (define (primitive-arity-correct? primitive argument-count)
  169.   (if (eq? primitive compiled-error-procedure)
  170.       (positive? argument-count)
  171.       (let ((arity (primitive-procedure-arity primitive)))
  172.     (or (= arity -1)
  173.         (= arity argument-count)))))
  174.  
  175. ;;;; Special Compiler Support
  176.  
  177. (define compiled-error-procedure
  178.   "Compiled error procedure")
  179.  
  180. (define lambda-tag:delay
  181.   (intern "#[delay-lambda]"))
  182.  
  183. (define (non-pointer-object? object)
  184.   ;; Any reason not to use `object/non-pointer?' here? -- cph
  185.   (or (object-type? (ucode-type false) object)
  186.       (object-type? (ucode-type true) object)
  187.       (fix:fixnum? object)
  188.       (object-type? (ucode-type character) object)
  189.       (object-type? (ucode-type unassigned) object)
  190.       (object-type? (ucode-type the-environment) object)
  191.       (object-type? (ucode-type manifest-nm-vector) object)
  192.       (object-type? (ucode-type manifest-special-nm-vector) object)))
  193.  
  194. (define (object-immutable? object)
  195.   (or (non-pointer-object? object)
  196.       (number? object)
  197.       (symbol? object)
  198.       (scode/primitive-procedure? object)
  199.       (eq? object compiled-error-procedure)))
  200.  
  201. (define boolean-valued-function-names
  202.   '(
  203.     OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING?
  204.     NUMBER? CHAR? PROMISE? BIT-STRING? CELL?
  205.     COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT?
  206.     ZERO? POSITIVE? NEGATIVE? ODD? EVEN?
  207.     = < > <= >=
  208.     FIX:FIXNUM? FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:>
  209.     FLO:FLONUM? FLO:ZERO? FLO:NEGATIVE? FLO:POSITIVE? FLO:= FLO:< FLO:>
  210.     INT:INTEGER? INT:ZERO? INT:NEGATIVE? INT:POSITIVE? INT:= INT:< INT:>
  211.     NOT BIT-STRING-REF
  212.     ))
  213.  
  214. (define function-names
  215.   (append
  216.    boolean-valued-function-names
  217.    '(
  218.      ;; Numbers
  219.      MAX MIN + - * / 1+ -1+ CONJUGATE ABS QUOTIENT REMAINDER MODULO
  220.      INTEGER-DIVIDE GCD LCM NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND
  221.      FLOOR->EXACT CEILING->EXACT TRUNCATE->EXACT ROUND->EXACT
  222.      RATIONALIZE RATIONALIZE->EXACT SIMPLEST-RATIONAL SIMPLEST-EXACT-RATIONAL
  223.      EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT MAKE-RECTANGULAR MAKE-POLAR
  224.      REAL-PART IMAG-PART MAGNITUDE ANGLE EXACT->INEXACT INEXACT->EXACT
  225.      FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:*
  226.      FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER
  227.      FIX:AND FIX:ANDC FIX:NOT FIX:OR FIX:XOR
  228.  
  229.      INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS
  230.      INT:1+ INT:-1+ INT:NEGATE
  231.      FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS
  232.      FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR
  233.      FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT
  234.      FLO:TRUNCATE->EXACT FLO:ROUND->EXACT
  235.  
  236.      ;; Random
  237.      OBJECT-TYPE CHAR-ASCII? ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE
  238.      CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR
  239.      PRIMITIVE-PROCEDURE-ARITY
  240.  
  241.      ;; References (assumes immediate constants are immutable)
  242.      CAR CDR LENGTH
  243.      VECTOR-REF VECTOR-LENGTH
  244.      STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH
  245.      BIT-STRING-LENGTH
  246.      )))
  247.  
  248. ;; The following definition is used to avoid computation if possible.
  249. ;; Not to avoid recomputation.  To avoid recomputation, function-names
  250. ;; should be used.
  251. ;;
  252. ;; Example: CONS has no side effects, yet it is not a function.
  253. ;; Thus if the result of a CONS is not going to be used, we can avoid the
  254. ;; CONS operation, yet we can't reuse its result even when given the same
  255. ;; arguments again because the two pairs should not be EQ?.
  256.  
  257. (define side-effect-free-additional-names
  258.   `(
  259.     ;; Constructors
  260.     CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY
  261.     LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL
  262.     ))
  263.  
  264. (define additional-boolean-valued-function-primitives
  265.   (list (ucode-primitive zero?)
  266.     (ucode-primitive positive?)
  267.     (ucode-primitive negative?)
  268.     (ucode-primitive &=)
  269.     (ucode-primitive &<)
  270.     (ucode-primitive &>)))
  271.  
  272. (define additional-function-primitives
  273.   (list (ucode-primitive 1+)
  274.     (ucode-primitive -1+)
  275.     (ucode-primitive &+)
  276.     (ucode-primitive &-)
  277.     (ucode-primitive &*)
  278.     (ucode-primitive &/)))
  279.  
  280. ;;;; "Foldable" and side-effect-free operators
  281.  
  282. (define boolean-valued-function-variables)
  283. (define function-variables)
  284. (define side-effect-free-variables)
  285. (define boolean-valued-function-primitives)
  286. (define function-primitives)
  287. (define side-effect-free-primitives)
  288.  
  289. (let ((global-valued
  290.        (lambda (names)
  291.      (list-transform-negative names
  292.        (lambda (name)
  293.          (lexical-unreferenceable? system-global-environment name)))))
  294.       (global-value
  295.        (lambda (name)
  296.      (lexical-reference system-global-environment name)))
  297.       (primitives
  298.        (let ((primitive-procedure?
  299.           (lexical-reference system-global-environment
  300.                  'PRIMITIVE-PROCEDURE?)))
  301.      (lambda (procedures)
  302.        (list-transform-positive procedures primitive-procedure?)))))
  303.   (let ((names (global-valued boolean-valued-function-names)))
  304.     (let ((procedures (map global-value names)))
  305.       (set! boolean-valued-function-variables (map cons names procedures))
  306.       (set! boolean-valued-function-primitives
  307.         (append! (primitives procedures)
  308.              additional-boolean-valued-function-primitives))))
  309.   (let ((names (global-valued function-names)))
  310.     (let ((procedures (map global-value names)))
  311.       (set! function-variables
  312.         (map* boolean-valued-function-variables cons names procedures))
  313.       (set! function-primitives
  314.         (append! (primitives procedures)
  315.              (append additional-function-primitives
  316.                  boolean-valued-function-primitives)))))
  317.   (let ((names (global-valued side-effect-free-additional-names)))
  318.     (let ((procedures (map global-value names)))
  319.       (set! side-effect-free-variables
  320.         (map* function-variables cons names procedures))
  321.       (set! side-effect-free-primitives
  322.         (append! (primitives procedures)
  323.              function-primitives))
  324.       unspecific)))
  325.  
  326. (define-integrable (boolean-valued-function-variable? name)
  327.   (assq name boolean-valued-function-variables))
  328.  
  329. (define-integrable (constant-foldable-variable? name)
  330.   (assq name function-variables))
  331.  
  332. (define-integrable (side-effect-free-variable? name)
  333.   (assq name side-effect-free-variables))
  334.  
  335. (define (variable-usual-definition name)
  336.   (let ((place (assq name side-effect-free-variables)))
  337.     (and place
  338.      (cdr place))))
  339.  
  340. (define-integrable (boolean-valued-function-primitive? operator)
  341.   (memq operator boolean-valued-function-primitives))
  342.  
  343. (define-integrable (constant-foldable-primitive? operator)
  344.   (memq operator function-primitives))
  345.  
  346. (define-integrable (side-effect-free-primitive? operator)
  347.   (memq operator side-effect-free-primitives))
  348.  
  349. (define procedure-object?
  350.   (lexical-reference system-global-environment 'PROCEDURE?))
  351.  
  352. ;;!(define (careful-object-datum object)
  353. ;;!  ;; This works correctly when cross-compiling.
  354. ;;!  (if (and (object-type? (ucode-type fixnum) object)
  355. ;;!       (negative? object))
  356. ;;!      (+ object unsigned-fixnum/upper-limit)
  357. ;;!      (object-datum object)))
  358.  
  359. (define (careful-object-datum object)
  360.   ;; This works correctly when cross-compiling.
  361.   (if (and (fix:fixnum? object)
  362.        (negative? object))
  363.       (+ object unsigned-fixnum/upper-limit)
  364.       (object-datum object)))
  365.  
  366.