home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / derive.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  14.5 KB  |  309 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/derive.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFUN DEFINE-USUAL-SYNTAX
  9.        (NAME EXPANDER)
  10.        (DECLARE (SPECIAL REVISED^4-SCHEME-ENV))
  11.        (PROGRAM-ENV-DEFINE! REVISED^4-SCHEME-ENV
  12.                             NAME
  13.                             (MAKE-MACRO
  14.                               #'(LAMBDA (FORM R C)
  15.                                  (APPLY EXPANDER R C (CDR FORM)))
  16.                               REVISED^4-SCHEME-ENV)))
  17. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE-USUAL-SYNTAX
  18.                               'SCHEME::DEFINE-USUAL-SYNTAX)
  19. (LOCALLY (DECLARE (SPECIAL REWRITE-SYNTAX-RULES
  20.                            REVISED^4-SCHEME-ENV))
  21.          (PROGRAM-ENV-DEFINE! REVISED^4-SCHEME-ENV
  22.                               'SCHEME::SYNTAX-RULES
  23.                               (MAKE-MACRO REWRITE-SYNTAX-RULES
  24.                                           REVISED^4-SCHEME-ENV)))
  25. (SCHI:AT-TOP-LEVEL
  26.   (DEFINE-USUAL-SYNTAX 'SCHEME::AND
  27.                        #'(LAMBDA (R C &REST CONJUNCTS) #+:LISPM
  28.                           (SETQ CONJUNCTS (COPY-LIST CONJUNCTS)) C
  29.                           (IF (NULL CONJUNCTS) SCHI:TRUE
  30.                            (LABELS
  31.                             ((RECUR (.FIRST .REST)
  32.                               (IF (NULL .REST) .FIRST
  33.                                (CONS (FUNCALL R 'SCHEME::AND-AUX)
  34.                                 (CONS .FIRST
  35.                                  (LIST
  36.                                   (CONS (FUNCALL R 'SCHEME::LAMBDA)
  37.                                    (CONS 'NIL
  38.                                     (LIST (RECUR (CAR .REST) (CDR .REST)))))))))))
  39.                             (RECUR (CAR CONJUNCTS) (CDR CONJUNCTS)))))))
  40. (SCHI:AT-TOP-LEVEL
  41.   (DEFINE-USUAL-SYNTAX 'SCHEME::OR
  42.                        #'(LAMBDA (R C &REST DISJUNCTS) #+:LISPM
  43.                           (SETQ DISJUNCTS (COPY-LIST DISJUNCTS)) C
  44.                           (IF (NULL DISJUNCTS) SCHI:FALSE
  45.                            (LABELS
  46.                             ((RECUR (.FIRST .REST)
  47.                               (IF (NULL .REST) .FIRST
  48.                                (CONS (FUNCALL R 'SCHEME::OR-AUX)
  49.                                 (CONS .FIRST
  50.                                  (LIST
  51.                                   (CONS (FUNCALL R 'SCHEME::LAMBDA)
  52.                                    (CONS 'NIL
  53.                                     (LIST (RECUR (CAR .REST) (CDR .REST)))))))))))
  54.                             (RECUR (CAR DISJUNCTS) (CDR DISJUNCTS)))))))
  55. (SCHI:AT-TOP-LEVEL
  56.   (DEFINE-USUAL-SYNTAX 'SCHEME::CASE
  57.                        #'(LAMBDA (R C KEY &REST CLAUSES) #+:LISPM
  58.                           (SETQ CLAUSES (COPY-LIST CLAUSES))
  59.                           (FLET
  60.                            ((FORM-RESULT (ELSE-THUNK THUNKS KEY-LISTS)
  61.                              (CONS (FUNCALL R 'SCHEME::CASE-AUX)
  62.                               (CONS KEY
  63.                                (CONS
  64.                                 (CONS (FUNCALL R 'SCHEME::QUOTE)
  65.                                  (LIST (REVERSE KEY-LISTS)))
  66.                                 (CONS ELSE-THUNK (REVERSE THUNKS)))))))
  67.                            (PROG (CS THUNKS KEY-LISTS)
  68.                             (PSETQ CS CLAUSES THUNKS 'NIL KEY-LISTS 'NIL)
  69.                             (GO .LOOP) .LOOP
  70.                             (IF (NULL CS)
  71.                              (RETURN
  72.                               (FORM-RESULT
  73.                                (CONS (FUNCALL R 'SCHEME::LAMBDA)
  74.                                 (CONS 'NIL
  75.                                  (LIST (FUNCALL R 'SCHEME::UNSPECIFIED))))
  76.                                THUNKS KEY-LISTS))
  77.                              (LET ((CLAUSE (CAR CS)))
  78.                               (LET ((KEY-LIST (CAR CLAUSE)))
  79.                                (LET ((BODY (CDR CLAUSE)))
  80.                                 (IF
  81.                                  (SCHI:TRUEP
  82.                                   (FUNCALL C KEY-LIST
  83.                                    (FUNCALL R 'SCHEME::ELSE)))
  84.                                  (RETURN
  85.                                   (FORM-RESULT
  86.                                    (CONS (FUNCALL R 'SCHEME::LAMBDA)
  87.                                     (CONS 'NIL BODY))
  88.                                    THUNKS KEY-LISTS))
  89.                                  (PROGN
  90.                                   (PSETQ CS (CDR CS) THUNKS
  91.                                    (CONS
  92.                                     (CONS (FUNCALL R 'SCHEME::LAMBDA)
  93.                                      (CONS 'NIL BODY))
  94.                                     THUNKS)
  95.                                    KEY-LISTS (CONS KEY-LIST KEY-LISTS))
  96.                                   (GO .LOOP))))))))))))
  97. (SCHI:AT-TOP-LEVEL
  98.   (DEFINE-USUAL-SYNTAX 'SCHEME::COND
  99.                        #'(LAMBDA (R C &REST CLAUSES) #+:LISPM
  100.                           (SETQ CLAUSES (COPY-LIST CLAUSES))
  101.                           (LABELS
  102.                            ((RECUR (CLAUSES@0)
  103.                              (IF (NULL CLAUSES@0)
  104.                               (FUNCALL R 'SCHEME::UNSPECIFIED)
  105.                               (PROCESS-COND-CLAUSE R C (CAR CLAUSES@0)
  106.                                (RECUR (CDR CLAUSES@0))))))
  107.                            (RECUR CLAUSES)))))
  108. (DEFUN PROCESS-COND-CLAUSE
  109.        (R C CLAUSE .REST)
  110.        (IF (NULL (CDR CLAUSE))
  111.            (CONS (FUNCALL R 'SCHEME::OR-AUX)
  112.                  (CONS (CAR CLAUSE)
  113.                        (LIST
  114.                          (CONS (FUNCALL R 'SCHEME::LAMBDA)
  115.                                (CONS 'NIL (LIST .REST))))))
  116.            (IF (SCHI:TRUEP
  117.                  (FUNCALL C
  118.                           (CAR CLAUSE)
  119.                           (FUNCALL R 'SCHEME::ELSE)))
  120.                (CONS (FUNCALL R 'SCHEME::BEGIN)
  121.                      (CDR CLAUSE))
  122.                (IF (SCHI:TRUEP
  123.                      (FUNCALL C
  124.                               (CADR CLAUSE)
  125.                               (FUNCALL R 'SCHEME::=>)))
  126.                    (CONS (FUNCALL R 'SCHEME::=>-AUX)
  127.                          (CONS (CAR CLAUSE)
  128.                                (CONS
  129.                                  (CONS (FUNCALL R
  130.                                                 'SCHEME::LAMBDA)
  131.                                        (CONS 'NIL
  132.                                              (LIST (CADDR CLAUSE))))
  133.                                  (LIST
  134.                                    (CONS (FUNCALL R
  135.                                                   'SCHEME::LAMBDA)
  136.                                          (CONS 'NIL
  137.                                                (LIST .REST)))))))
  138.                    (CONS (FUNCALL R 'SCHEME::IF)
  139.                          (CONS (CAR CLAUSE)
  140.                                (CONS
  141.                                  (CONS (FUNCALL R 'SCHEME::BEGIN)
  142.                                        (CDR CLAUSE))
  143.                                  (LIST .REST))))))))
  144. (SCHI:SET-VALUE-FROM-FUNCTION 'PROCESS-COND-CLAUSE
  145.                               'SCHEME::PROCESS-COND-CLAUSE)
  146. (SCHI:AT-TOP-LEVEL
  147.   (DEFINE-USUAL-SYNTAX 'SCHEME::DELAY
  148.                        #'(LAMBDA (R C THING) C
  149.                           (CONS (FUNCALL R 'SCHEME::MAKE-PROMISE)
  150.                            (LIST
  151.                             (CONS (FUNCALL R 'SCHEME::LAMBDA)
  152.                              (CONS 'NIL (LIST THING))))))))
  153. (SCHI:AT-TOP-LEVEL
  154.   (DEFINE-USUAL-SYNTAX 'SCHEME::DO
  155.                        #'(LAMBDA (R C SPECS END &REST BODY) #+:LISPM
  156.                           (SETQ BODY (COPY-LIST BODY)) C
  157.                           (LET ((.LOOP (FUNCALL R 'SCHEME::LOOP)))
  158.                            (CONS (FUNCALL R 'SCHEME::LETREC)
  159.                             (CONS
  160.                              (LIST
  161.                               (CONS .LOOP
  162.                                (LIST
  163.                                 (CONS (FUNCALL R 'SCHEME::LAMBDA)
  164.                                  (CONS (MAPCAR #'CAR SPECS)
  165.                                   (LIST
  166.                                    (PROCESS-COND-CLAUSE R C END
  167.                                     (CONS (FUNCALL R 'SCHEME::BEGIN)
  168.                                      (APPEND BODY
  169.                                       (LIST
  170.                                        (CONS .LOOP
  171.                                         (MAPCAR
  172.                                          #'(LAMBDA (Y)
  173.                                             (IF (NULL (CDDR Y)) (CAR Y)
  174.                                              (CADDR Y)))
  175.                                          SPECS))))))))))))
  176.                              (LIST (CONS .LOOP (MAPCAR #'CADR SPECS)))))))))
  177. (SCHI:AT-TOP-LEVEL
  178.   (DEFINE-USUAL-SYNTAX 'SCHEME::LET
  179.                        #'(LAMBDA (R C SPECS &REST BODY) #+:LISPM
  180.                           (SETQ BODY (COPY-LIST BODY)) C
  181.                           (IF (SCHI:TRUEP (NAME? SPECS))
  182.                            (LET
  183.                             ((TAG SPECS) (SPECS@0 (CAR BODY))
  184.                              (BODY@1 (CDR BODY)))
  185.                             (CONS (FUNCALL R 'SCHEME::LETREC)
  186.                              (CONS
  187.                               (LIST
  188.                                (CONS TAG
  189.                                 (LIST
  190.                                  (CONS (FUNCALL R 'SCHEME::LAMBDA)
  191.                                   (CONS (MAPCAR #'CAR SPECS@0) BODY@1)))))
  192.                               (LIST (CONS TAG (MAPCAR #'CADR SPECS@0))))))
  193.                            (CONS
  194.                             (CONS (FUNCALL R 'SCHEME::LAMBDA)
  195.                              (CONS (MAPCAR #'CAR SPECS) BODY))
  196.                             (MAPCAR #'CADR SPECS))))))
  197. (SCHI:AT-TOP-LEVEL
  198.   (DEFINE-USUAL-SYNTAX 'SCHEME::LET*
  199.                        #'(LAMBDA (R C SPECS &REST BODY) #+:LISPM
  200.                           (SETQ BODY (COPY-LIST BODY)) C
  201.                           (LABELS
  202.                            ((RECUR (SPECS@0)
  203.                              (IF (NULL SPECS@0)
  204.                               (CONS (FUNCALL R 'SCHEME::BEGIN) BODY)
  205.                               (LET
  206.                                ((NAME (CAR (CAR SPECS@0)))
  207.                                 (VAL-EXP (CADR (CAR SPECS@0))))
  208.                                (CONS (FUNCALL R 'SCHEME::LET)
  209.                                 (CONS (LIST (CONS NAME (LIST VAL-EXP)))
  210.                                  (LIST (RECUR (CDR SPECS@0)))))))))
  211.                            (RECUR SPECS)))))
  212. (SCHI:AT-TOP-LEVEL
  213.   (DEFINE-USUAL-SYNTAX 'SCHEME::QUASIQUOTE
  214.                        #'(LAMBDA (R C X) C (QQ-DESCEND X 1 R))))
  215. (DEFUN QQ-DESCEND
  216.        (X LEVEL R)
  217.        (IF (SCHI:TRUEP (VECTOR? X))
  218.            (QQ-DESCEND-VECTOR X LEVEL R)
  219.            (IF (NOT (CONSP X))
  220.                (MAKE-QUOTATION X R)
  221.                (IF (SCHI:TRUEP (QQ-INTERESTING? X
  222.                                                 'SCHEME::QUASIQUOTE))
  223.                    (QQ-DESCEND-PAIR X (+ LEVEL 1) R)
  224.                    (IF (SCHI:TRUEP (QQ-INTERESTING? X
  225.                                                     'SCHEME::UNQUOTE))
  226.                        (IF (= LEVEL 1)
  227.                            (CADR X)
  228.                            (QQ-DESCEND-PAIR X (- LEVEL 1) R))
  229.                        (IF (SCHI:TRUEP
  230.                              (QQ-INTERESTING? X
  231.                                               'SCHEME::UNQUOTE-SPLICING))
  232.                            (IF (= LEVEL 1)
  233.                                (.ERROR ",@ in illegal position"
  234.                                        X)
  235.                                (QQ-DESCEND-PAIR X (- LEVEL 1) R))
  236.                            (QQ-DESCEND-PAIR X LEVEL R)))))))
  237. (SCHI:SET-VALUE-FROM-FUNCTION 'QQ-DESCEND
  238.                               'SCHEME::QQ-DESCEND)
  239. (DEFUN QQ-DESCEND-PAIR
  240.        (X LEVEL R)
  241.        (LET ((D-EXP (QQ-DESCEND (CDR X) LEVEL R)))
  242.          (IF (AND
  243.                (SCHI:TRUEP (QQ-INTERESTING? (CAR X)
  244.                                             'SCHEME::UNQUOTE-SPLICING))
  245.                (= LEVEL 1))
  246.              (LET ((SC (CADR (CAR X))))
  247.                (IF (AND (SCHI:TRUEP (QUOTATION? D-EXP R))
  248.                         (NULL (QUOTATION-VALUE D-EXP)))
  249.                    SC
  250.                    (CONS (FUNCALL R 'SCHEME::APPEND)
  251.                          (CONS SC (LIST D-EXP)))))
  252.              (LET ((A-EXP (QQ-DESCEND (CAR X) LEVEL R)))
  253.                (IF (AND (SCHI:TRUEP (QUOTATION? A-EXP R))
  254.                         (SCHI:TRUEP (QUOTATION? D-EXP R)))
  255.                    (MAKE-QUOTATION X R)
  256.                    (IF (AND (SCHI:TRUEP (QUOTATION? D-EXP R))
  257.                             (EQ (QUOTATION-VALUE D-EXP)
  258.                                 'NIL))
  259.                        (CONS (FUNCALL R 'SCHEME::LIST)
  260.                              (LIST A-EXP))
  261.                        (IF (SCHI:TRUEP (QQ-INTERESTING? D-EXP
  262.                                                         'SCHEME::LIST))
  263.                            (CONS (FUNCALL R 'SCHEME::LIST)
  264.                                  (CONS A-EXP (CDR D-EXP)))
  265.                            (CONS (FUNCALL R 'SCHEME::CONS)
  266.                                  (CONS A-EXP (LIST D-EXP))))))))))
  267. (SCHI:SET-VALUE-FROM-FUNCTION 'QQ-DESCEND-PAIR
  268.                               'SCHEME::QQ-DESCEND-PAIR)
  269. (DEFUN QQ-DESCEND-VECTOR
  270.        (X LEVEL R)
  271.        (LET ((RESULT
  272.                (QQ-DESCEND (COERCE (THE SIMPLE-VECTOR X)
  273.                                    'LIST)
  274.                            LEVEL
  275.                            R)))
  276.          (IF (SCHI:TRUEP (QUOTATION? RESULT R))
  277.              (MAKE-QUOTATION X R)
  278.              (CONS (FUNCALL R 'SCHEME::LIST->VECTOR)
  279.                    (LIST RESULT)))))
  280. (SCHI:SET-VALUE-FROM-FUNCTION 'QQ-DESCEND-VECTOR
  281.                               'SCHEME::QQ-DESCEND-VECTOR)
  282. (DEFUN QQ-INTERESTING?
  283.        (X MARKER)
  284.        (IF (CONSP X)
  285.            (IF (EQ (CAR X) MARKER)
  286.                (IF (CONSP (CDR X))
  287.                    (SCHI:TRUE? (NULL (CDDR X)))
  288.                    SCHI:FALSE)
  289.                SCHI:FALSE)
  290.            SCHI:FALSE))
  291. (SCHI:SET-VALUE-FROM-FUNCTION 'QQ-INTERESTING?
  292.                               'SCHEME::QQ-INTERESTING?)
  293. (DEFUN QUOTATION?
  294.        (X R)
  295.        (QQ-INTERESTING? X
  296.                         (FUNCALL R 'SCHEME::QUOTE)))
  297. (SCHI:SET-VALUE-FROM-FUNCTION 'QUOTATION?
  298.                               'SCHEME::QUOTATION?)
  299. (LOCALLY (DECLARE (SPECIAL QUOTATION-VALUE))
  300.          (SETQ QUOTATION-VALUE #'CADR))
  301. (SCHI:SET-FUNCTION-FROM-VALUE 'QUOTATION-VALUE
  302.                               'SCHEME::QUOTATION-VALUE)
  303. (DEFUN MAKE-QUOTATION
  304.        (VALUE R)
  305.        (CONS (FUNCALL R 'SCHEME::QUOTE)
  306.              (LIST VALUE)))
  307. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-QUOTATION
  308.                               'SCHEME::MAKE-QUOTATION)
  309.