home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / strategy.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  9.1 KB  |  201 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-TRANSLATOR; -*-
  2.  
  3. ; This file was generated by Pseudoscheme 2.8a
  4. ;  running in Lucid Common Lisp 4.0.1
  5. ;  from file /amd/night/b/jar/pseudo/strategy.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN GET-LETREC-STRATEGY
  9.        (NODE)
  10.        (DECLARE (SPECIAL N-ARY? VARIABLE-VALUE-REFS?))
  11.        (LET ((TEMP (LETREC-STRATEGY NODE)))
  12.          (IF (SCHI:TRUEP TEMP)
  13.              TEMP
  14.              (LET ((STRATEGY
  15.                      (LET ((VARS (LETREC-VARS NODE))
  16.                            (VALS (LETREC-VALS NODE)))
  17.                        (IF (OR (NULL VARS)
  18.                                (NOT
  19.                                  (SCHI:TRUEP (FUNCTION-BINDABLE? VARS VALS))))
  20.                            'SCHEME::GENERAL
  21.                            (IF (OR
  22.                                  (SCHI:TRUEP
  23.                                    (.SOME VARIABLE-VALUE-REFS? VARS))
  24.                                  (SCHI:TRUEP (.SOME N-ARY? VALS))
  25.                                  (SCHI:TRUEP (EXISTS-LOSING-CALL? NODE)))
  26.                                'SCHEME::LABELS
  27.                                'SCHEME::PROG)))))
  28.                (SET-LETREC-STRATEGY! NODE STRATEGY)
  29.                STRATEGY))))
  30. (SCHI:SET-VALUE-FROM-FUNCTION 'GET-LETREC-STRATEGY
  31.                               'SCHEME::GET-LETREC-STRATEGY)
  32. (DEFUN EXISTS-LOSING-CALL?
  33.        (NODE)
  34.        (LET ((VARS (LETREC-VARS NODE)))
  35.          (LET ((TEMP (CONTAINS-LOSER? (LETREC-BODY NODE)
  36.                                       VARS
  37.                                       'SCHEME::WIN)))
  38.            (IF (SCHI:TRUEP TEMP)
  39.                TEMP
  40.                (.SOME
  41.                  #'(LAMBDA (PROC) (CALL-WILL-LOSE? PROC VARS 'SCHEME::WIN))
  42.                  (LETREC-VALS NODE))))))
  43. (SCHI:SET-VALUE-FROM-FUNCTION 'EXISTS-LOSING-CALL?
  44.                               'SCHEME::EXISTS-LOSING-CALL?)
  45. (DEFUN CONTAINS-LOSER?
  46.        (NODE VARS K)
  47.        (CASE (NODE-TYPE NODE)
  48.              ((SCHEME::LOCAL-VARIABLE SCHEME::PROGRAM-VARIABLE
  49.                                       SCHEME::CONSTANT)
  50.                SCHI:FALSE)
  51.              ((SCHEME::LETREC)
  52.                (LET ((TEMP (CONTAINS-LOSER? (LETREC-BODY NODE)
  53.                                             VARS
  54.                                             K)))
  55.                  (IF (SCHI:TRUEP TEMP)
  56.                      TEMP
  57.                      (IF (EQ (GET-LETREC-STRATEGY NODE)
  58.                              'SCHEME::PROG)
  59.                          (.SOME
  60.                            #'(LAMBDA (PROC) (CALL-WILL-LOSE? PROC VARS K))
  61.                            (LETREC-VALS NODE))
  62.                          (LIST-CONTAINS-LOSER? (LETREC-VALS NODE)
  63.                                                VARS
  64.                                                'SCHEME::LOSE)))))
  65.              ((SCHEME::IF)
  66.                (LET ((TEMP
  67.                        (CONTAINS-LOSER? (IF-TEST NODE)
  68.                                         VARS
  69.                                         'SCHEME::LOSE)))
  70.                  (IF (SCHI:TRUEP TEMP)
  71.                      TEMP
  72.                      (LET ((TEMP@0 (CONTAINS-LOSER? (IF-CON NODE)
  73.                                                     VARS
  74.                                                     K)))
  75.                        (IF (SCHI:TRUEP TEMP@0)
  76.                            TEMP@0
  77.                            (CONTAINS-LOSER? (IF-ALT NODE)
  78.                                             VARS
  79.                                             K))))))
  80.              ((SCHEME::BEGIN)
  81.                (LET ((TEMP
  82.                        (CONTAINS-LOSER? (BEGIN-FIRST NODE)
  83.                                         VARS
  84.                                         'SCHEME::LOSE)))
  85.                  (IF (SCHI:TRUEP TEMP)
  86.                      TEMP
  87.                      (CONTAINS-LOSER? (BEGIN-SECOND NODE)
  88.                                       VARS
  89.                                       K))))
  90.              ((SCHEME::SET!)
  91.                (CONTAINS-LOSER? (SET!-RHS NODE)
  92.                                 VARS
  93.                                 'SCHEME::LOSE))
  94.              ((SCHEME::LAMBDA)
  95.                (CONTAINS-LOSER? (LAMBDA-BODY NODE)
  96.                                 VARS
  97.                                 'SCHEME::LOSE))
  98.              ((SCHEME::CALL)
  99.                (LET ((PROC (CALL-PROC NODE)))
  100.                  (IF (SCHI:TRUEP (LAMBDA? PROC))
  101.                      (LET ((TEMP (CALL-WILL-LOSE? PROC VARS K)))
  102.                        (IF (SCHI:TRUEP TEMP)
  103.                            TEMP
  104.                            (LIST-CONTAINS-LOSER? (CALL-ARGS NODE)
  105.                                                  VARS
  106.                                                  'SCHEME::LOSE)))
  107.                      (IF (SCHI:TRUEP (PROGRAM-VARIABLE? PROC))
  108.                          (LET ((N (NUMBER-OF-NON-CONTINUATION-ARGS PROC)))
  109.                            (IF (SCHI:TRUEP N)
  110.                                (PROG (A@1 I@2)
  111.                                      (PSETQ A@1
  112.                                             (CALL-ARGS NODE)
  113.                                             I@2
  114.                                             0)
  115.                                      (GO .LOOP)
  116.                                  .LOOP (LET ((A A@1)
  117.                                              (I I@2))
  118.                                          (IF (= I N)
  119.                                              (RETURN
  120.                                                (.SOME
  121.                                                  #'(LAMBDA (ARG)
  122.                                                     (CALL-WILL-LOSE? ARG VARS K))
  123.                                                  A))
  124.                                              (LET ((TEMP
  125.                                                      (CONTAINS-LOSER? (CAR A)
  126.                                                                       VARS
  127.                                                                       'SCHEME::LOSE)))
  128.                                                (IF (SCHI:TRUEP TEMP)
  129.                                                    (RETURN TEMP)
  130.                                                    (PROGN
  131.                                                      (PSETQ A@1
  132.                                                             (CDR A)
  133.                                                             I@2
  134.                                                             (+ I 1))
  135.                                                      (GO .LOOP)))))))
  136.                                (LIST-CONTAINS-LOSER? (CALL-ARGS NODE)
  137.                                                      VARS
  138.                                                      'SCHEME::LOSE)))
  139.                          (LET ((TEMP
  140.                                  (IF (MEMBER PROC VARS :TEST #'EQ)
  141.                                      (SCHI:TRUE? (EQ K
  142.                                                      'SCHEME::LOSE))
  143.                                      (CONTAINS-LOSER? PROC
  144.                                                       VARS
  145.                                                       'SCHEME::LOSE))))
  146.                            (IF (SCHI:TRUEP TEMP)
  147.                                TEMP
  148.                                (LIST-CONTAINS-LOSER? (CALL-ARGS NODE)
  149.                                                      VARS
  150.                                                      'SCHEME::LOSE)))))))
  151.              (OTHERWISE (.ERROR "unknown node type" NODE))))
  152. (SCHI:SET-VALUE-FROM-FUNCTION 'CONTAINS-LOSER?
  153.                               'SCHEME::CONTAINS-LOSER?)
  154. (DEFUN LIST-CONTAINS-LOSER?
  155.        (NODE-LIST VARS K)
  156.        (.SOME #'(LAMBDA (NODE)
  157.                         (CONTAINS-LOSER? NODE VARS K))
  158.               NODE-LIST))
  159. (SCHI:SET-VALUE-FROM-FUNCTION 'LIST-CONTAINS-LOSER?
  160.                               'SCHEME::LIST-CONTAINS-LOSER?)
  161. (DEFUN CALL-WILL-LOSE?
  162.        (PROC-NODE VARS K)
  163.        (IF (SCHI:TRUEP (LAMBDA? PROC-NODE))
  164.            (CONTAINS-LOSER? (LAMBDA-BODY PROC-NODE)
  165.                             VARS
  166.                             K)
  167.            (CONTAINS-LOSER? PROC-NODE VARS 'SCHEME::LOSE)))
  168. (SCHI:SET-VALUE-FROM-FUNCTION 'CALL-WILL-LOSE?
  169.                               'SCHEME::CALL-WILL-LOSE?)
  170. (DEFUN NUMBER-OF-NON-CONTINUATION-ARGS
  171.        (VAR)
  172.        (IF (OR (EQ VAR
  173.                    (BUILT-IN 'SCHEME::AND-AUX))
  174.                (EQ VAR
  175.                    (BUILT-IN 'SCHEME::OR-AUX)))
  176.            1
  177.            (IF (EQ VAR
  178.                    (BUILT-IN 'SCHEME::=>-AUX))
  179.                2
  180.                (IF (EQ VAR
  181.                        (BUILT-IN 'SCHEME::CASE-AUX))
  182.                    1
  183.                    SCHI:FALSE))))
  184. (SCHI:SET-VALUE-FROM-FUNCTION 'NUMBER-OF-NON-CONTINUATION-ARGS
  185.                               'SCHEME::NUMBER-OF-NON-CONTINUATION-ARGS)
  186. (DEFUN FUNCTION-BINDABLE?
  187.        (VARS VALS)
  188.        (DECLARE (SPECIAL LAMBDA?))
  189.        (IF (NOT (NULL VARS))
  190.            (IF (SCHI:TRUEP
  191.                  (.EVERY
  192.                    #'(LAMBDA (VAR)
  193.                       (SCHI:TRUE?
  194.                        (NOT (SCHI:TRUEP (VARIABLE-ASSIGNED? VAR)))))
  195.                    VARS))
  196.                (.EVERY LAMBDA? VALS)
  197.                SCHI:FALSE)
  198.            SCHI:FALSE))
  199. (SCHI:SET-VALUE-FROM-FUNCTION 'FUNCTION-BINDABLE?
  200.                               'SCHEME::FUNCTION-BINDABLE?)
  201.