home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / module.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  13.7 KB  |  277 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/module.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (LOCALLY (DECLARE (SPECIAL SIGNATURE-RTD))
  9.          (SETQ SIGNATURE-RTD (MAKE-RECORD-TYPE 'SCHEME::SIGNATURE
  10.                                                '(SCHEME::ID SCHEME::NAMES
  11.                                                  SCHEME::AUX-NAMES))))
  12. (SCHI:SET-FUNCTION-FROM-VALUE 'SIGNATURE-RTD
  13.                               'SCHEME::SIGNATURE-RTD)
  14. (LOCALLY (DECLARE (SPECIAL MAKE-SIGNATURE
  15.                            SIGNATURE-RTD))
  16.          (SETQ MAKE-SIGNATURE (RECORD-CONSTRUCTOR SIGNATURE-RTD
  17.                                                   '(SCHEME::ID SCHEME::NAMES
  18.                                                     SCHEME::AUX-NAMES))))
  19. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-SIGNATURE
  20.                               'SCHEME::MAKE-SIGNATURE)
  21. (LOCALLY (DECLARE (SPECIAL SIGNATURE-NAMES
  22.                            SIGNATURE-RTD))
  23.          (SETQ SIGNATURE-NAMES (RECORD-ACCESSOR SIGNATURE-RTD
  24.                                                 'SCHEME::NAMES)))
  25. (SCHI:SET-FUNCTION-FROM-VALUE 'SIGNATURE-NAMES
  26.                               'SCHEME::SIGNATURE-NAMES)
  27. (LOCALLY (DECLARE (SPECIAL SIGNATURE-AUX-NAMES
  28.                            SIGNATURE-RTD))
  29.          (SETQ SIGNATURE-AUX-NAMES (RECORD-ACCESSOR SIGNATURE-RTD
  30.                                                     'SCHEME::AUX-NAMES)))
  31. (SCHI:SET-FUNCTION-FROM-VALUE 'SIGNATURE-AUX-NAMES
  32.                               'SCHEME::SIGNATURE-AUX-NAMES)
  33. (DEFUN SIGNATURE-REF
  34.        (SIG NAME)
  35.        (IF (MEMBER NAME
  36.                    (SIGNATURE-NAMES SIG)
  37.                    :TEST
  38.                    #'EQ)
  39.            'SCHEME::PUBLIC
  40.            SCHI:FALSE))
  41. (SCHI:SET-VALUE-FROM-FUNCTION 'SIGNATURE-REF
  42.                               'SCHEME::SIGNATURE-REF)
  43. (DEFUN SIGNATURE-REF-AUX
  44.        (SIG NAME)
  45.        (IF (MEMBER NAME
  46.                    (SIGNATURE-NAMES SIG)
  47.                    :TEST
  48.                    #'EQ)
  49.            'SCHEME::PUBLIC
  50.            (IF (MEMBER NAME
  51.                        (SIGNATURE-AUX-NAMES SIG)
  52.                        :TEST
  53.                        #'EQ)
  54.                'SCHEME::PRIVATE
  55.                SCHI:FALSE)))
  56. (SCHI:SET-VALUE-FROM-FUNCTION 'SIGNATURE-REF-AUX
  57.                               'SCHEME::SIGNATURE-REF-AUX)
  58. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-RTD))
  59.          (SETQ PROGRAM-ENV-RTD (MAKE-RECORD-TYPE 'SCHEME::PROGRAM-ENV
  60.                                                  '(SCHEME::ID SCHEME::USE-LIST
  61.                                                    SCHEME::TABLE
  62.                                                    SCHEME::PACKAGE))))
  63. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV-RTD
  64.                               'SCHEME::PROGRAM-ENV-RTD)
  65. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-ID
  66.                            PROGRAM-ENV-RTD))
  67.          (SETQ PROGRAM-ENV-ID (RECORD-ACCESSOR PROGRAM-ENV-RTD
  68.                                                'SCHEME::ID)))
  69. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV-ID
  70.                               'SCHEME::PROGRAM-ENV-ID)
  71. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-USE-LIST
  72.                            PROGRAM-ENV-RTD))
  73.          (SETQ PROGRAM-ENV-USE-LIST (RECORD-ACCESSOR PROGRAM-ENV-RTD
  74.                                                      'SCHEME::USE-LIST)))
  75. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV-USE-LIST
  76.                               'SCHEME::PROGRAM-ENV-USE-LIST)
  77. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-TABLE
  78.                            PROGRAM-ENV-RTD))
  79.          (SETQ PROGRAM-ENV-TABLE (RECORD-ACCESSOR PROGRAM-ENV-RTD
  80.                                                   'SCHEME::TABLE)))
  81. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV-TABLE
  82.                               'SCHEME::PROGRAM-ENV-TABLE)
  83. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-PACKAGE
  84.                            PROGRAM-ENV-RTD))
  85.          (SETQ PROGRAM-ENV-PACKAGE (RECORD-ACCESSOR PROGRAM-ENV-RTD
  86.                                                     'SCHEME::PACKAGE)))
  87. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV-PACKAGE
  88.                               'SCHEME::PROGRAM-ENV-PACKAGE)
  89. (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV?
  90.                            PROGRAM-ENV-RTD))
  91.          (SETQ PROGRAM-ENV? (RECORD-PREDICATE PROGRAM-ENV-RTD)))
  92. (SCHI:SET-FUNCTION-FROM-VALUE 'PROGRAM-ENV?
  93.                               'SCHEME::PROGRAM-ENV?)
  94. (SCHI:AT-TOP-LEVEL
  95.   (LOCALLY (DECLARE (SPECIAL MAKE-PROGRAM-ENV
  96.                              PROGRAM-ENV-RTD
  97.                              MODULE-PACKAGE))
  98.            (SETQ MAKE-PROGRAM-ENV (LET ((CREATE
  99.                                           (RECORD-CONSTRUCTOR PROGRAM-ENV-RTD
  100.                                                               '(SCHEME::ID
  101.                                                                 SCHEME::USE-LIST
  102.                                                                 SCHEME::TABLE
  103.                                                                 SCHEME::PACKAGE))))
  104.                                     #'(LAMBDA (ID USE-LIST)
  105.                                        (LET
  106.                                         ((ENV
  107.                                           (FUNCALL CREATE ID USE-LIST
  108.                                            (MAKE-TABLE)
  109.                                            (MAKE-PACKAGE-USING ID
  110.                                             (MAPCAR MODULE-PACKAGE USE-LIST)))))
  111.                                         (INIT-ENVIRONMENT-FOR-SYNTAX! ENV) ENV))))
  112.                  ))
  113. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-PROGRAM-ENV
  114.                               'SCHEME::MAKE-PROGRAM-ENV)
  115. (SCHI:AT-TOP-LEVEL
  116.   (LOCALLY (DECLARE (SPECIAL PROGRAM-ENV-RTD))
  117.            (DEFINE-RECORD-DISCLOSER PROGRAM-ENV-RTD
  118.                                     #'(LAMBDA (R)
  119.                                        (LIST "Program-env" (PROGRAM-ENV-ID R))))))
  120. (DEFUN PROGRAM-ENV-LOOKUP
  121.        (PROGRAM-ENV NAME)
  122.        (LET ((TEMP (TABLE-REF (PROGRAM-ENV-TABLE PROGRAM-ENV)
  123.                               NAME)))
  124.          (IF (SCHI:TRUEP TEMP)
  125.              TEMP
  126.              (LET ((Q?
  127.                      (IF (SCHI:SCHEME-SYMBOL-P NAME)
  128.                          (QUALIFIED-SYMBOL? NAME)
  129.                          SCHI:FALSE)))
  130.                (LET ((TEMP@2
  131.                        (IF (NOT (SCHI:TRUEP Q?))
  132.                            (PROG (MODS@0)
  133.                                  (SETQ MODS@0 (PROGRAM-ENV-USE-LIST PROGRAM-ENV))
  134.                                        
  135.                                  (GO .LOOP)
  136.                              .LOOP (LET ((MODS MODS@0))
  137.                                      (IF (NOT (NULL MODS))
  138.                                          (LET ((TEMP@1
  139.                                                  (MODULE-REF (CAR MODS)
  140.                                                              NAME)))
  141.                                            (IF (SCHI:TRUEP TEMP@1)
  142.                                                (RETURN TEMP@1)
  143.                                                (PROGN
  144.                                                  (SETQ MODS@0 (CDR MODS))
  145.                                                  (GO .LOOP))))
  146.                                          (RETURN SCHI:FALSE))))
  147.                            SCHI:FALSE)))
  148.                  (IF (SCHI:TRUEP TEMP@2)
  149.                      TEMP@2
  150.                      (LET ((NODE
  151.                              (MAKE-PROGRAM-VARIABLE NAME
  152.                                                     (IF (SCHI:TRUEP Q?)
  153.                                                         NAME
  154.                                                         (SCHEME-HACKS:INTERN-RENAMING-PERHAPS
  155.                                                           (NAME->STRING NAME)
  156.                                                           (PROGRAM-ENV-PACKAGE
  157.                                                             PROGRAM-ENV))))))
  158.                        (TABLE-SET! (PROGRAM-ENV-TABLE PROGRAM-ENV)
  159.                                    NAME
  160.                                    NODE)
  161.                        NODE)))))))
  162. (SCHI:SET-VALUE-FROM-FUNCTION 'PROGRAM-ENV-LOOKUP
  163.                               'SCHEME::PROGRAM-ENV-LOOKUP)
  164. (DEFUN PROGRAM-ENV-DEFINE!
  165.        (PROGRAM-ENV NAME BINDING)
  166.        (TABLE-SET! (PROGRAM-ENV-TABLE PROGRAM-ENV)
  167.                    NAME
  168.                    BINDING))
  169. (SCHI:SET-VALUE-FROM-FUNCTION 'PROGRAM-ENV-DEFINE!
  170.                               'SCHEME::PROGRAM-ENV-DEFINE!)
  171. (LOCALLY (DECLARE (SPECIAL CLIENT-LOOKUP
  172.                            PROGRAM-ENV-LOOKUP))
  173.          (SETQ CLIENT-LOOKUP PROGRAM-ENV-LOOKUP))
  174. (SCHI:SET-FUNCTION-FROM-VALUE 'CLIENT-LOOKUP
  175.                               'SCHEME::CLIENT-LOOKUP)
  176. (LOCALLY (DECLARE (SPECIAL CLIENT-DEFINE!
  177.                            PROGRAM-ENV-DEFINE!))
  178.          (SETQ CLIENT-DEFINE! PROGRAM-ENV-DEFINE!))
  179. (SCHI:SET-FUNCTION-FROM-VALUE 'CLIENT-DEFINE!
  180.                               'SCHEME::CLIENT-DEFINE!)
  181. (LOCALLY (DECLARE (SPECIAL ENVIRONMENT-FOR-SYNTAX-KEY))
  182.          (SETQ ENVIRONMENT-FOR-SYNTAX-KEY (LIST
  183.                                             'SCHEME::ENVIRONMENT-FOR-SYNTAX-KEY))
  184.                )
  185. (SCHI:SET-FUNCTION-FROM-VALUE 'ENVIRONMENT-FOR-SYNTAX-KEY
  186.                               'SCHEME::ENVIRONMENT-FOR-SYNTAX-KEY)
  187. (DEFUN GET-ENVIRONMENT-FOR-SYNTAX
  188.        (ENV)
  189.        (DECLARE (SPECIAL ENVIRONMENT-FOR-SYNTAX-KEY))
  190.        (FORCE (LOOKUP ENV ENVIRONMENT-FOR-SYNTAX-KEY)))
  191. (SCHI:SET-VALUE-FROM-FUNCTION 'GET-ENVIRONMENT-FOR-SYNTAX
  192.                               'SCHEME::GET-ENVIRONMENT-FOR-SYNTAX)
  193. (DEFUN DEFINE-TRANSFORMER-ENV!
  194.        (ENV T-ENV-PROMISE)
  195.        (DECLARE (SPECIAL ENVIRONMENT-FOR-SYNTAX-KEY))
  196.        (DEFINE! ENV ENVIRONMENT-FOR-SYNTAX-KEY T-ENV-PROMISE))
  197. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE-TRANSFORMER-ENV!
  198.                               'SCHEME::DEFINE-TRANSFORMER-ENV!)
  199. (DEFUN INIT-ENVIRONMENT-FOR-SYNTAX!
  200.        (ENV)
  201.        (DECLARE (SPECIAL REVISED^4-SCHEME-MODULE))
  202.        (DEFINE-TRANSFORMER-ENV! ENV
  203.                                 (REVISED^4-SCHEME::MAKE-PROMISE
  204.                                   #'(LAMBDA NIL
  205.                                      (MAKE-PROGRAM-ENV
  206.                                       (VALUES
  207.                                        (INTERN
  208.                                         (STRING-APPEND
  209.                                          (SYMBOL->STRING (PROGRAM-ENV-ID ENV))
  210.                                          "[META]")
  211.                                         SCHI:SCHEME-PACKAGE))
  212.                                       (LIST REVISED^4-SCHEME-MODULE))))))
  213. (SCHI:SET-VALUE-FROM-FUNCTION 'INIT-ENVIRONMENT-FOR-SYNTAX!
  214.                               'SCHEME::INIT-ENVIRONMENT-FOR-SYNTAX!)
  215. (LOCALLY (DECLARE (SPECIAL MODULE-RTD))
  216.          (SETQ MODULE-RTD (MAKE-RECORD-TYPE 'SCHEME::MODULE
  217.                                             '(SCHEME::ID SCHEME::SIG
  218.                                               SCHEME::PROGRAM-ENV
  219.                                               SCHEME::PACKAGE))))
  220. (SCHI:SET-FUNCTION-FROM-VALUE 'MODULE-RTD
  221.                               'SCHEME::MODULE-RTD)
  222. (SCHI:AT-TOP-LEVEL
  223.   (LOCALLY (DECLARE (SPECIAL MAKE-MODULE MODULE-RTD))
  224.            (SETQ MAKE-MODULE (LET ((CREATE
  225.                                      (RECORD-CONSTRUCTOR MODULE-RTD
  226.                                                          '(SCHEME::ID
  227.                                                            SCHEME::SIG
  228.                                                            SCHEME::PROGRAM-ENV
  229.                                                            SCHEME::PACKAGE))))
  230.                                #'(LAMBDA (ID SIG ENV)
  231.                                   (FUNCALL CREATE ID SIG ENV
  232.                                    (MAKE-PACKAGE-EXPORTING ID
  233.                                     (LET
  234.                                      ((PPACKAGE (PROGRAM-ENV-PACKAGE ENV)))
  235.                                      (MAPCAR
  236.                                       #'(LAMBDA (NAME)
  237.                                          (SCHEME-HACKS:INTERN-RENAMING-PERHAPS
  238.                                           (SYMBOL->STRING NAME) PPACKAGE))
  239.                                       (SIGNATURE-NAMES SIG))))))))))
  240. (SCHI:SET-FUNCTION-FROM-VALUE 'MAKE-MODULE
  241.                               'SCHEME::MAKE-MODULE)
  242. (LOCALLY (DECLARE (SPECIAL MODULE-ID MODULE-RTD))
  243.          (SETQ MODULE-ID (RECORD-ACCESSOR MODULE-RTD 'SCHEME::ID)))
  244. (SCHI:SET-FUNCTION-FROM-VALUE 'MODULE-ID
  245.                               'SCHEME::MODULE-ID)
  246. (LOCALLY (DECLARE (SPECIAL MODULE-SIGNATURE MODULE-RTD))
  247.          (SETQ MODULE-SIGNATURE (RECORD-ACCESSOR MODULE-RTD
  248.                                                  'SCHEME::SIG)))
  249. (SCHI:SET-FUNCTION-FROM-VALUE 'MODULE-SIGNATURE
  250.                               'SCHEME::MODULE-SIGNATURE)
  251. (LOCALLY (DECLARE (SPECIAL MODULE-PROGRAM-ENV
  252.                            MODULE-RTD))
  253.          (SETQ MODULE-PROGRAM-ENV (RECORD-ACCESSOR MODULE-RTD
  254.                                                    'SCHEME::PROGRAM-ENV)))
  255. (SCHI:SET-FUNCTION-FROM-VALUE 'MODULE-PROGRAM-ENV
  256.                               'SCHEME::MODULE-PROGRAM-ENV)
  257. (LOCALLY (DECLARE (SPECIAL MODULE-PACKAGE MODULE-RTD))
  258.          (SETQ MODULE-PACKAGE (RECORD-ACCESSOR MODULE-RTD
  259.                                                'SCHEME::PACKAGE)))
  260. (SCHI:SET-FUNCTION-FROM-VALUE 'MODULE-PACKAGE
  261.                               'SCHEME::MODULE-PACKAGE)
  262. (SCHI:AT-TOP-LEVEL
  263.   (LOCALLY (DECLARE (SPECIAL MODULE-RTD))
  264.            (DEFINE-RECORD-DISCLOSER MODULE-RTD
  265.                                     #'(LAMBDA (R)
  266.                                        (LIST "Module" (MODULE-ID R))))))
  267. (DEFUN MODULE-REF
  268.        (.MOD NAME)
  269.        (IF (EQ (SIGNATURE-REF (MODULE-SIGNATURE .MOD)
  270.                               NAME)
  271.                'SCHEME::PUBLIC)
  272.            (PROGRAM-ENV-LOOKUP (MODULE-PROGRAM-ENV .MOD)
  273.                                NAME)
  274.            SCHI:FALSE))
  275. (SCHI:SET-VALUE-FROM-FUNCTION 'MODULE-REF
  276.                               'SCHEME::MODULE-REF)
  277.