home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / emit.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  12.4 KB  |  311 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/emit.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (LOCALLY (DECLARE (SPECIAL @TARGET-PACKAGE))
  9.          (SETQ @TARGET-PACKAGE (MAKE-FLUID SCHI:FALSE)))
  10. (SCHI:SET-FUNCTION-FROM-VALUE '@TARGET-PACKAGE
  11.                               'SCHEME::@TARGET-PACKAGE)
  12. (LOCALLY (DECLARE (SPECIAL @TRANSLATING-TO-FILE?))
  13.          (SETQ @TRANSLATING-TO-FILE? (MAKE-FLUID SCHI:FALSE)))
  14. (SCHI:SET-FUNCTION-FROM-VALUE '@TRANSLATING-TO-FILE?
  15.                               'SCHEME::@TRANSLATING-TO-FILE?)
  16. (DEFUN EMIT-PROGRAM-VARIABLE-SET!
  17.        (VAR CL-SYM RHS-CODE)
  18.        (IF (SCHI:TRUEP (MUTABLE-PROGRAM-VARIABLE? VAR))
  19.            (CONS 'SETQ
  20.                  (CONS CL-SYM (LIST RHS-CODE)))
  21.            (CONS 'SCHI:SET!-AUX
  22.                  (CONS (CONS 'QUOTE
  23.                              (LIST (PROGRAM-VARIABLE-NAME VAR)))
  24.                        (CONS RHS-CODE
  25.                              (LIST (CONS 'QUOTE
  26.                                          (LIST CL-SYM))))))))
  27. (SCHI:SET-VALUE-FROM-FUNCTION 'EMIT-PROGRAM-VARIABLE-SET!
  28.                               'SCHEME::EMIT-PROGRAM-VARIABLE-SET!)
  29. (DEFUN SUBSTITUTE-AND-PEEP
  30.        (ALIST CL-FORM)
  31.        (IF (SCHI:SCHEME-SYMBOL-P CL-FORM)
  32.            (LET ((PROBE (SCHI:TRUE? (ASSOC CL-FORM ALIST :TEST #'EQ))))
  33.              (IF (SCHI:TRUEP PROBE)
  34.                  (CDR PROBE)
  35.                  CL-FORM))
  36.            (IF (CONSP CL-FORM)
  37.                (LET ((YOW
  38.                        (MAPCAR #'(LAMBDA (Z)
  39.                                          (SUBSTITUTE-AND-PEEP ALIST Z))
  40.                                CL-FORM)))
  41.                  (CASE (CAR YOW)
  42.                        ((FUNCALL) (FUNCALLIFY (CADR YOW)
  43.                                               (CDDR YOW)))
  44.                        (OTHERWISE YOW))))))
  45. (SCHI:SET-VALUE-FROM-FUNCTION 'SUBSTITUTE-AND-PEEP
  46.                               'SCHEME::SUBSTITUTE-AND-PEEP)
  47. (DEFUN INSERT-&REST
  48.        (L)
  49.        (IF (NULL (CDR L))
  50.            (CONS '&REST L)
  51.            (CONS (CAR L)
  52.                  (INSERT-&REST (CDR L)))))
  53. (SCHI:SET-VALUE-FROM-FUNCTION 'INSERT-&REST
  54.                               'SCHEME::INSERT-&REST)
  55. (DEFUN CL-EXTERNALIZE-LOCALS
  56.        (VARS ENV)
  57.        (MAPCAR
  58.          #'(LAMBDA (VAR) (CL-EXTERNALIZE-LOCAL (LOCAL-VARIABLE-NAME VAR) ENV))
  59.          VARS))
  60. (SCHI:SET-VALUE-FROM-FUNCTION 'CL-EXTERNALIZE-LOCALS
  61.                               'SCHEME::CL-EXTERNALIZE-LOCALS)
  62. (DEFUN CL-EXTERNALIZE-LOCAL
  63.        (NAME ENV)
  64.        (IF (SCHI:TRUEP (QUALIFIED-SYMBOL? NAME))
  65.            NAME
  66.            (IF (SCHI:TRUEP (NAME-IN-USE? NAME ENV))
  67.                (IN-TARGET-PACKAGE (MAKE-NAME-FROM-UID NAME
  68.                                                       (GENERATE-UID)))
  69.                (IN-TARGET-PACKAGE (NAME->SYMBOL NAME)))))
  70. (SCHI:SET-VALUE-FROM-FUNCTION 'CL-EXTERNALIZE-LOCAL
  71.                               'SCHEME::CL-EXTERNALIZE-LOCAL)
  72. (DEFUN GENERATION-ENV
  73.        (FREE-VARS)
  74.        (DECLARE (SPECIAL PROGRAM-VARIABLE-NAME))
  75.        (MAPCAR PROGRAM-VARIABLE-NAME FREE-VARS))
  76. (SCHI:SET-VALUE-FROM-FUNCTION 'GENERATION-ENV
  77.                               'SCHEME::GENERATION-ENV)
  78. (DEFUN BIND-VARIABLES
  79.        (VARS NEW-NAMES ENV)
  80.        (MAPC #'(LAMBDA (VAR NEW-NAME)
  81.                        (SET-SUBSTITUTION! VAR NEW-NAME))
  82.              VARS
  83.              NEW-NAMES)
  84.        (GBIND VARS ENV))
  85. (SCHI:SET-VALUE-FROM-FUNCTION 'BIND-VARIABLES
  86.                               'SCHEME::BIND-VARIABLES)
  87. (DEFUN BIND-FUNCTIONS
  88.        (VARS NEW-NAMES ENV)
  89.        (MAPC
  90.          #'(LAMBDA (VAR NEW-NAME)
  91.             (SET-SUBSTITUTION! VAR (CONS 'SCHEME::FUN (LIST NEW-NAME))))
  92.          VARS
  93.          NEW-NAMES)
  94.        (GBIND VARS ENV))
  95. (SCHI:SET-VALUE-FROM-FUNCTION 'BIND-FUNCTIONS
  96.                               'SCHEME::BIND-FUNCTIONS)
  97. (DEFUN GBIND
  98.        (VARS ENV)
  99.        (DECLARE (SPECIAL LOCAL-VARIABLE-NAME))
  100.        (APPEND (MAPCAR LOCAL-VARIABLE-NAME VARS)
  101.                ENV))
  102. (SCHI:SET-VALUE-FROM-FUNCTION 'GBIND 'SCHEME::GBIND)
  103. (LOCALLY (DECLARE (SPECIAL NAME-IN-USE? MEMQ))
  104.          (SETQ NAME-IN-USE? MEMQ))
  105. (SCHI:SET-FUNCTION-FROM-VALUE 'NAME-IN-USE?
  106.                               'SCHEME::NAME-IN-USE?)
  107. (DEFUN MUTABLE-PROGRAM-VARIABLE?
  108.        (VAR)
  109.        (LET ((NAME (PROGRAM-VARIABLE-NAME VAR)))
  110.          (IF (NOT (SCHI:TRUEP (QUALIFIED-SYMBOL? NAME)))
  111.              (LET ((S (SYMBOL->STRING NAME)))
  112.                (LET ((N (LENGTH (THE SIMPLE-STRING S))))
  113.                  (IF (>= N 3)
  114.                      (IF (CHAR= (CHAR (THE SIMPLE-STRING S)
  115.                                       0)
  116.                                 #\*)
  117.                          (SCHI:TRUE?
  118.                            (CHAR= (CHAR (THE SIMPLE-STRING S)
  119.                                         (- N 1))
  120.                                   #\*))
  121.                          SCHI:FALSE)
  122.                      SCHI:FALSE)))
  123.              SCHI:FALSE)))
  124. (SCHI:SET-VALUE-FROM-FUNCTION 'MUTABLE-PROGRAM-VARIABLE?
  125.                               'SCHEME::MUTABLE-PROGRAM-VARIABLE?)
  126. (DEFUN IN-TARGET-PACKAGE
  127.        (SYM)
  128.        (DECLARE (SPECIAL @TARGET-PACKAGE
  129.                          @TRANSLATING-TO-FILE?))
  130.        (IF (SCHI:TRUEP (FLUID @TRANSLATING-TO-FILE?))
  131.            (CHANGE-PACKAGE SYM (FLUID @TARGET-PACKAGE))
  132.            SYM))
  133. (SCHI:SET-VALUE-FROM-FUNCTION 'IN-TARGET-PACKAGE
  134.                               'SCHEME::IN-TARGET-PACKAGE)
  135. (DEFUN CHANGE-PACKAGE
  136.        (SYM .PACKAGE)
  137.        (IF (AND (SCHI:TRUEP .PACKAGE)
  138.                 (NOT (SCHI:TRUEP (QUALIFIED-SYMBOL? SYM))))
  139.            (INTERN-RENAMING-PERHAPS (SYMBOL->STRING SYM)
  140.                                     .PACKAGE)
  141.            SYM))
  142. (SCHI:SET-VALUE-FROM-FUNCTION 'CHANGE-PACKAGE
  143.                               'SCHEME::CHANGE-PACKAGE)
  144. (DEFUN PROGNIFY
  145.        (FORM-LIST)
  146.        (IF (NULL (CDR FORM-LIST))
  147.            (CAR FORM-LIST)
  148.            (CONS 'PROGN FORM-LIST)))
  149. (SCHI:SET-VALUE-FROM-FUNCTION 'PROGNIFY
  150.                               'SCHEME::PROGNIFY)
  151. (DEFUN DEPROGNIFY
  152.        (CL-FORM)
  153.        (IF (SCHI:TRUEP (CAR-IS? CL-FORM 'PROGN))
  154.            (CDR CL-FORM)
  155.            (LIST CL-FORM)))
  156. (SCHI:SET-VALUE-FROM-FUNCTION 'DEPROGNIFY
  157.                               'SCHEME::DEPROGNIFY)
  158. (DEFUN DEANDIFY
  159.        (CL-FORM)
  160.        (IF (SCHI:TRUEP (CAR-IS? CL-FORM 'AND))
  161.            (CDR CL-FORM)
  162.            (LIST CL-FORM)))
  163. (SCHI:SET-VALUE-FROM-FUNCTION 'DEANDIFY
  164.                               'SCHEME::DEANDIFY)
  165. (DEFUN DEORIFY
  166.        (CL-FORM)
  167.        (IF (SCHI:TRUEP (CAR-IS? CL-FORM 'OR))
  168.            (CDR CL-FORM)
  169.            (LIST CL-FORM)))
  170. (SCHI:SET-VALUE-FROM-FUNCTION 'DEORIFY 'SCHEME::DEORIFY)
  171. (DEFUN FUNCALLIFY
  172.        (FUN ARGS)
  173.        (IF (SCHI:TRUEP (CAR-IS? FUN 'FUNCTION))
  174.            (LET ((FUN@0 (CADR FUN)))
  175.              (IF (AND (SCHI:TRUEP (CAR-IS? FUN@0 'LAMBDA))
  176.                       (NOT (MEMBER '&REST
  177.                                    (CADR FUN@0)
  178.                                    :TEST
  179.                                    #'EQ))
  180.                       (= (LENGTH (CADR FUN@0))
  181.                          (LENGTH ARGS)))
  182.                  (LETIFY (MAPCAR #'LIST (CADR FUN@0) ARGS)
  183.                          (PROGNIFY (CDDR FUN@0)))
  184.                  (CONS FUN@0 ARGS)))
  185.            (CONS 'FUNCALL (CONS FUN ARGS))))
  186. (SCHI:SET-VALUE-FROM-FUNCTION 'FUNCALLIFY
  187.                               'SCHEME::FUNCALLIFY)
  188. (DEFUN LETIFY
  189.        (SPECS BODY)
  190.        (IF (NULL SPECS)
  191.            BODY
  192.            (CONS 'LET
  193.                  (CONS SPECS (DEPROGNIFY BODY)))))
  194. (SCHI:SET-VALUE-FROM-FUNCTION 'LETIFY 'SCHEME::LETIFY)
  195. (DEFUN SHARP-QUOTE-LAMBDA?
  196.        (.EXP)
  197.        (IF (SCHI:TRUEP (CAR-IS? .EXP 'FUNCTION))
  198.            (CAR-IS? (CADR .EXP) 'LAMBDA)
  199.            SCHI:FALSE))
  200. (SCHI:SET-VALUE-FROM-FUNCTION 'SHARP-QUOTE-LAMBDA?
  201.                               'SCHEME::SHARP-QUOTE-LAMBDA?)
  202. (LOCALLY (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES))
  203.          (SETQ @CL-VARIABLE-REFERENCES (MAKE-FLUID 'SCHEME::DONT-ACCUMULATE)))
  204. (SCHI:SET-FUNCTION-FROM-VALUE '@CL-VARIABLE-REFERENCES
  205.                               'SCHEME::@CL-VARIABLE-REFERENCES)
  206. (DEFUN NOTING-VARIABLE-REFERENCES
  207.        (THUNK)
  208.        (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES))
  209.        (LET-FLUID @CL-VARIABLE-REFERENCES 'NIL THUNK))
  210. (SCHI:SET-VALUE-FROM-FUNCTION 'NOTING-VARIABLE-REFERENCES
  211.                               'SCHEME::NOTING-VARIABLE-REFERENCES)
  212. (DEFUN LOCALLY-SPECIALIZE
  213.        (FORM-LIST)
  214.        (DECLARE (SPECIAL @CL-VARIABLE-REFERENCES
  215.                          PROGRAM-VARIABLE-CL-SYMBOL))
  216.        (LET ((VARS (FLUID @CL-VARIABLE-REFERENCES)))
  217.          (IF (OR (NULL VARS)
  218.                  (AND (CONSP FORM-LIST)
  219.                       (CONSP (CAR FORM-LIST))
  220.                       (MEMBER (CAAR FORM-LIST)
  221.                               '(DEFUN DEFSTRUCT DEFTYPE)
  222.                               :TEST
  223.                               #'EQ)))
  224.              FORM-LIST
  225.              (LIST
  226.                (CONS 'LOCALLY
  227.                      (CONS
  228.                        (CONS 'DECLARE
  229.                              (LIST
  230.                                (CONS 'SPECIAL
  231.                                      (MAPCAR PROGRAM-VARIABLE-CL-SYMBOL VARS))))
  232.                        FORM-LIST))))))
  233. (SCHI:SET-VALUE-FROM-FUNCTION 'LOCALLY-SPECIALIZE
  234.                               'SCHEME::LOCALLY-SPECIALIZE)
  235. (DEFUN EMIT-SHARP-PLUS
  236.        (FEATURE CODE)
  237.        (DECLARE (SPECIAL @TRANSLATING-TO-FILE?))
  238.        (IF (SCHI:TRUEP (FLUID @TRANSLATING-TO-FILE?))
  239.            (CONS
  240.              (MAKE-PHOTON
  241.                #'(LAMBDA (PORT) (DISPLAY "#+" PORT) (PRIN1 FEATURE PORT)))
  242.              (LIST CODE))
  243.            (IF (MEMBER FEATURE *FEATURES* :TEST #'EQ)
  244.                (LIST CODE)
  245.                'NIL)))
  246. (SCHI:SET-VALUE-FROM-FUNCTION 'EMIT-SHARP-PLUS
  247.                               'SCHEME::EMIT-SHARP-PLUS)
  248. (DEFUN EMIT-TOP-LEVEL
  249.        (CODE)
  250.        (DECLARE (SPECIAL @LAMBDA-ENCOUNTERED?))
  251.        (IF (SCHI:TRUEP (FLUID @LAMBDA-ENCOUNTERED?))
  252.            (CONS 'SCHI:AT-TOP-LEVEL CODE)
  253.            (PROGNIFY CODE)))
  254. (SCHI:SET-VALUE-FROM-FUNCTION 'EMIT-TOP-LEVEL
  255.                               'SCHEME::EMIT-TOP-LEVEL)
  256. (LOCALLY (DECLARE (SPECIAL CONT/VALUE))
  257.          (SETQ CONT/VALUE '(SCHEME::CONT/VALUE)))
  258. (SCHI:SET-FUNCTION-FROM-VALUE 'CONT/VALUE
  259.                               'SCHEME::CONT/VALUE)
  260. (LOCALLY (DECLARE (SPECIAL CONT/RETURN))
  261.          (SETQ CONT/RETURN '(SCHEME::CONT/RETURN)))
  262. (SCHI:SET-FUNCTION-FROM-VALUE 'CONT/RETURN
  263.                               'SCHEME::CONT/RETURN)
  264. (LOCALLY (DECLARE (SPECIAL CONT/TEST))
  265.          (SETQ CONT/TEST '(SCHEME::CONT/TEST)))
  266. (SCHI:SET-FUNCTION-FROM-VALUE 'CONT/TEST
  267.                               'SCHEME::CONT/TEST)
  268. (LOCALLY (DECLARE (SPECIAL CONT/IGNORE))
  269.          (SETQ CONT/IGNORE '(SCHEME::CONT/IGNORE)))
  270. (SCHI:SET-FUNCTION-FROM-VALUE 'CONT/IGNORE
  271.                               'SCHEME::CONT/IGNORE)
  272. (LOCALLY (DECLARE (SPECIAL CONTINUATION-TYPE))
  273.          (SETQ CONTINUATION-TYPE #'CAR))
  274. (SCHI:SET-FUNCTION-FROM-VALUE 'CONTINUATION-TYPE
  275.                               'SCHEME::CONTINUATION-TYPE)
  276. (DEFUN DELIVER-VALUE-TO-CONT
  277.        (RESULT-EXP CONT)
  278.        (CASE (CONTINUATION-TYPE CONT)
  279.              ((SCHEME::CONT/VALUE SCHEME::CONT/IGNORE) RESULT-EXP)
  280.              ((SCHEME::CONT/RETURN) (CONS 'RETURN
  281.                                           (LIST RESULT-EXP)))
  282.              ((SCHEME::CONT/TEST) (VALUE-FORM->TEST-FORM RESULT-EXP))
  283.              (OTHERWISE (.ERROR "unrecognized continuation"
  284.                                 CONT))))
  285. (SCHI:SET-VALUE-FROM-FUNCTION 'DELIVER-VALUE-TO-CONT
  286.                               'SCHEME::DELIVER-VALUE-TO-CONT)
  287. (DEFUN DELIVER-TEST-TO-CONT
  288.        (TEST-EXP CONT)
  289.        (CASE (CONTINUATION-TYPE CONT)
  290.              ((SCHEME::CONT/TEST SCHEME::CONT/IGNORE) TEST-EXP)
  291.              ((SCHEME::CONT/RETURN)
  292.                (CONS 'RETURN
  293.                      (LIST (TEST-FORM->VALUE-FORM TEST-EXP))))
  294.              ((SCHEME::CONT/VALUE) (TEST-FORM->VALUE-FORM TEST-EXP))
  295.              (OTHERWISE (.ERROR "unrecognized continuation"
  296.                                 CONT))))
  297. (SCHI:SET-VALUE-FROM-FUNCTION 'DELIVER-TEST-TO-CONT
  298.                               'SCHEME::DELIVER-TEST-TO-CONT)
  299. (DEFUN TEST-FORM->VALUE-FORM
  300.        (CL-FORM)
  301.        (CONS 'SCHI:TRUE? (LIST CL-FORM)))
  302. (SCHI:SET-VALUE-FROM-FUNCTION 'TEST-FORM->VALUE-FORM
  303.                               'SCHEME::TEST-FORM->VALUE-FORM)
  304. (DEFUN VALUE-FORM->TEST-FORM
  305.        (CL-FORM)
  306.        (IF (SCHI:TRUEP (CAR-IS? CL-FORM 'SCHI:TRUE?))
  307.            (CADR CL-FORM)
  308.            (CONS 'SCHI:TRUEP (LIST CL-FORM))))
  309. (SCHI:SET-VALUE-FROM-FUNCTION 'VALUE-FORM->TEST-FORM
  310.                               'SCHEME::VALUE-FORM->TEST-FORM)
  311.