home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / p-record.pso < prev    next >
Encoding:
Text File  |  1992-02-17  |  12.1 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/p-record.scm
  6.  
  7. (SCHI:BEGIN-TRANSLATED-FILE)
  8. (DEFSTRUCT
  9.   (RECORD-TYPE-DESCRIPTOR (:CONSTRUCTOR MAKE-RTD)
  10.                           (:PRINT-FUNCTION PRINT-RTD)
  11.                           (:CONC-NAME "RTD-"))
  12.   IDENTIFICATION
  13.   UNIQUE-ID
  14.   FIELD-NAMES
  15.   CONSTRUCTOR-FUNCTION
  16.   PREDICATE-FUNCTION
  17.   ACCESSOR-FUNCTIONS)
  18. (LOCALLY (DECLARE (SPECIAL *RECORD-TYPE-UNIQUE-ID*))
  19.          (SETQ *RECORD-TYPE-UNIQUE-ID* 0))
  20. (SCHI:SET-FORWARDING-FUNCTION '*RECORD-TYPE-UNIQUE-ID*
  21.                               'SCHEME::*RECORD-TYPE-UNIQUE-ID*)
  22. (LOCALLY (DECLARE (SPECIAL PACKAGE-FOR-RECORD-FUNCTIONS))
  23.          (SETQ PACKAGE-FOR-RECORD-FUNCTIONS (MAKE-PACKAGE
  24.                                               (IF (FIND-PACKAGE ".RECORD")
  25.                                                   (LABELS
  26.                                                     ((.LOOP (N)
  27.                                                             (LET ((NAME
  28.                                                                     (STRING-APPEND
  29.                                                                       ".RECORD-"
  30.                                                                       (NUMBER->STRING
  31.                                                                       N))))
  32.                                                               (IF (FIND-PACKAGE
  33.                                                                     NAME)
  34.                                                                   (.LOOP
  35.                                                                     (+ N 1))
  36.                                                                   NAME))))
  37.                                                     (.LOOP 0))
  38.                                                   ".RECORD")
  39.                                               :USE
  40.                                               'NIL)))
  41. (SCHI:SET-FUNCTION-FROM-VALUE 'PACKAGE-FOR-RECORD-FUNCTIONS
  42.                               'SCHEME::PACKAGE-FOR-RECORD-FUNCTIONS)
  43. (DEFUN REALLY-MAKE-RECORD-TYPE
  44.        (TYPE-ID FIELD-NAMES)
  45.        (DECLARE
  46.          (SPECIAL *RECORD-TYPE-UNIQUE-ID*
  47.                   PRINT-RECORD
  48.                   PACKAGE-FOR-RECORD-FUNCTIONS
  49.                   STRING-APPEND))
  50.        (FLET
  51.          ((CONC (&REST THINGS)
  52.                 #+:LISPM
  53.                 (SETQ THINGS (COPY-LIST THINGS))
  54.                 (INTERN
  55.                   (APPLY STRING-APPEND
  56.                          (MAPCAR
  57.                            #'(LAMBDA (THING)
  58.                               (IF (SIMPLE-STRING-P THING) THING
  59.                                (IF (NUMBERP THING) (NUMBER->STRING THING)
  60.                                 (IF (SCHI:SCHEME-SYMBOL-P THING)
  61.                                  (SYMBOL-NAME THING) "?"))))
  62.                            THINGS))
  63.                   PACKAGE-FOR-RECORD-FUNCTIONS)))
  64.          (LET ((ID-SYMBOL (CONC TYPE-ID "#" *RECORD-TYPE-UNIQUE-ID*)))
  65.            (LET ((CONSTRUCTOR-FUNCTION (CONC 'SCHEME::MAKE-
  66.                                              ID-SYMBOL)))
  67.              (LET ((PREDICATE-FUNCTION (CONC ID-SYMBOL 'SCHEME::?)))
  68.                (LET ((ACCESSOR-FUNCTIONS
  69.                        (MAPCAR #'(LAMBDA (F)
  70.                                          (CONC ID-SYMBOL 'SCHEME::- F))
  71.                                FIELD-NAMES)))
  72.                  (LET ((RTD
  73.                          (MAKE-RTD :IDENTIFICATION
  74.                                    TYPE-ID
  75.                                    :UNIQUE-ID
  76.                                    *RECORD-TYPE-UNIQUE-ID*
  77.                                    :FIELD-NAMES
  78.                                    FIELD-NAMES
  79.                                    :CONSTRUCTOR-FUNCTION
  80.                                    CONSTRUCTOR-FUNCTION
  81.                                    :PREDICATE-FUNCTION
  82.                                    PREDICATE-FUNCTION
  83.                                    :ACCESSOR-FUNCTIONS
  84.                                    ACCESSOR-FUNCTIONS)))
  85.                    (SETF (GET ID-SYMBOL 'SCHEME::RTD)
  86.                          RTD)
  87.                    (LET ((*PACKAGE* PACKAGE-FOR-RECORD-FUNCTIONS))
  88.                      (EVAL
  89.                        (CONS 'DEFSTRUCT
  90.                              (CONS
  91.                                (CONS ID-SYMBOL
  92.                                      (CONS
  93.                                        (CONS ':CONSTRUCTOR
  94.                                              (CONS CONSTRUCTOR-FUNCTION
  95.                                                    '(NIL)))
  96.                                        (CONS
  97.                                          (CONS ':PRINT-FUNCTION
  98.                                                (LIST 'PRINT-RECORD))
  99.                                          (CONS
  100.                                            (CONS ':PREDICATE
  101.                                                  (LIST PREDICATE-FUNCTION))
  102.                                            '((:COPIER NIL) (:CONC-NAME NIL))))))
  103.                                ACCESSOR-FUNCTIONS))))
  104.                    (SETQ *RECORD-TYPE-UNIQUE-ID* (+ *RECORD-TYPE-UNIQUE-ID* 1))
  105.                          
  106.                    RTD)))))))
  107. (SCHI:SET-VALUE-FROM-FUNCTION 'REALLY-MAKE-RECORD-TYPE
  108.                               'SCHEME::REALLY-MAKE-RECORD-TYPE)
  109. (DEFUN RECORD-CONSTRUCTOR
  110.        (RTD &REST INIT-NAMES-OPTION)
  111.        #+:LISPM
  112.        (SETQ INIT-NAMES-OPTION (COPY-LIST INIT-NAMES-OPTION))
  113.        (LET ((CFUN (RTD-CONSTRUCTOR-FUNCTION RTD))
  114.              (FUNS
  115.                (MAPCAR #'(LAMBDA (NAME)
  116.                                  (RTD-ACCESSOR-FUNCTION RTD NAME))
  117.                        (IF (NULL INIT-NAMES-OPTION)
  118.                            (RTD-FIELD-NAMES RTD)
  119.                            (CAR INIT-NAMES-OPTION)))))
  120.          (UNLESS (COMPILED-FUNCTION-P (SYMBOL-FUNCTION CFUN))
  121.                  (COMPILE CFUN))
  122.          (COMPILE 'NIL
  123.                   (CONS 'LAMBDA
  124.                         (CONS FUNS
  125.                               (LIST
  126.                                 (CONS 'LET
  127.                                       (CONS
  128.                                         (LIST
  129.                                           (CONS 'SCHEME::THE-RECORD
  130.                                                 (LIST (LIST CFUN))))
  131.                                         (APPEND
  132.                                           (MAPCAR
  133.                                             #'(LAMBDA (FUN)
  134.                                                (CONS 'SETF
  135.                                                 (CONS
  136.                                                  (CONS FUN
  137.                                                   '(SCHEME::THE-RECORD))
  138.                                                  (LIST FUN))))
  139.                                             FUNS)
  140.                                           '(SCHEME::THE-RECORD))))))))))
  141. (SCHI:SET-VALUE-FROM-FUNCTION 'RECORD-CONSTRUCTOR
  142.                               'SCHEME::RECORD-CONSTRUCTOR)
  143. (DEFUN RECORD-PREDICATE
  144.        (RTD)
  145.        (LET ((FUN (RTD-PREDICATE-FUNCTION RTD)))
  146.          (COMPILE 'NIL
  147.                   (CONS 'LAMBDA
  148.                         (CONS '(SCHEME::X)
  149.                               (LIST
  150.                                 (CONS 'SCHI:TRUE?
  151.                                       (LIST (CONS FUN '(SCHEME::X))))))))))
  152. (SCHI:SET-VALUE-FROM-FUNCTION 'RECORD-PREDICATE
  153.                               'SCHEME::RECORD-PREDICATE)
  154. (DEFUN RECORD-ACCESSOR
  155.        (RTD NAME)
  156.        (LET ((FUN (RTD-ACCESSOR-FUNCTION RTD NAME)))
  157.          (UNLESS (COMPILED-FUNCTION-P (SYMBOL-FUNCTION FUN))
  158.                  (COMPILE FUN))
  159.          (SYMBOL-FUNCTION FUN)))
  160. (SCHI:SET-VALUE-FROM-FUNCTION 'RECORD-ACCESSOR
  161.                               'SCHEME::RECORD-ACCESSOR)
  162. (DEFUN RECORD-MODIFIER
  163.        (RTD NAME)
  164.        (LET ((FUN (RTD-ACCESSOR-FUNCTION RTD NAME)))
  165.          (COMPILE 'NIL
  166.                   (CONS 'LAMBDA
  167.                         (CONS '(SCHEME::X SCHEME::Y)
  168.                               (LIST
  169.                                 (CONS 'SETF
  170.                                       (CONS (CONS FUN '(SCHEME::X))
  171.                                             '(SCHEME::Y)))))))))
  172. (SCHI:SET-VALUE-FROM-FUNCTION 'RECORD-MODIFIER
  173.                               'SCHEME::RECORD-MODIFIER)
  174. (DEFUN RTD-ACCESSOR-FUNCTION
  175.        (RTD NAME)
  176.        (PROG (L A)
  177.              (PSETQ L
  178.                     (RTD-FIELD-NAMES RTD)
  179.                     A
  180.                     (RTD-ACCESSOR-FUNCTIONS RTD))
  181.              (GO .LOOP)
  182.          .LOOP (IF (NULL L)
  183.                    (RETURN
  184.                      (ERROR "~S is not a field name for ~S records"
  185.                             NAME
  186.                             (RTD-IDENTIFICATION RTD)))
  187.                    (IF (EQ NAME (CAR L))
  188.                        (RETURN (CAR A))
  189.                        (PROGN (PSETQ L (CDR L) A (CDR A))
  190.                               (GO .LOOP))))))
  191. (SCHI:SET-VALUE-FROM-FUNCTION 'RTD-ACCESSOR-FUNCTION
  192.                               'SCHEME::RTD-ACCESSOR-FUNCTION)
  193. (LOCALLY (DECLARE (SPECIAL RECORD-TYPE-TABLE))
  194.          (SETQ RECORD-TYPE-TABLE (MAKE-HASH-TABLE :TEST 'EQUAL)))
  195. (SCHI:SET-FUNCTION-FROM-VALUE 'RECORD-TYPE-TABLE
  196.                               'SCHEME::RECORD-TYPE-TABLE)
  197. (DEFUN MAKE-RECORD-TYPE
  198.        (TYPE-ID FIELD-NAMES)
  199.        (DECLARE (SPECIAL RECORD-TYPE-TABLE))
  200.        (LET ((KEY (CONS TYPE-ID FIELD-NAMES)))
  201.          (LET ((EXISTING (GETHASH KEY RECORD-TYPE-TABLE)))
  202.            (IF (AND (NOT (EQ EXISTING 'NIL))
  203.                     (PROGN
  204.                       (FORMAT *QUERY-IO*
  205.                               "~&Existing ~S has fields ~S.~%"
  206.                               EXISTING
  207.                               FIELD-NAMES)
  208.                       (NOT
  209.                         (EQ
  210.                           (Y-OR-N-P
  211.                             "Use that descriptor (instead of creating a new one)? ")
  212.                           'NIL))))
  213.                EXISTING
  214.                (LET ((NEW (REALLY-MAKE-RECORD-TYPE TYPE-ID FIELD-NAMES)))
  215.                  (SETF (GETHASH KEY RECORD-TYPE-TABLE)
  216.                        NEW)
  217.                  NEW)))))
  218. (SCHI:SET-VALUE-FROM-FUNCTION 'MAKE-RECORD-TYPE
  219.                               'SCHEME::MAKE-RECORD-TYPE)
  220. (DEFUN RECORD-TYPE
  221.        (RECORD)
  222.        (GET (TYPE-OF RECORD) 'SCHEME::RTD))
  223. (SCHI:SET-VALUE-FROM-FUNCTION 'RECORD-TYPE
  224.                               'SCHEME::RECORD-TYPE)
  225. (DEFUN PRINT-RTD
  226.        (RTD .STREAM ESCAPE?)
  227.        ESCAPE?
  228.        (FORMAT .STREAM
  229.                "#{Record-type-descriptor ~S.~S}"
  230.                (RTD-IDENTIFICATION RTD)
  231.                (RTD-UNIQUE-ID RTD)))
  232. (SCHI:SET-VALUE-FROM-FUNCTION 'PRINT-RTD
  233.                               'SCHEME::PRINT-RTD)
  234. (DEFUN PRINT-RECORD
  235.        (RECORD .STREAM ESCAPE?)
  236.        ESCAPE?
  237.        (LET ((D (DISCLOSE-RECORD RECORD)))
  238.          (DISPLAY "#{")
  239.          (DISPLAY
  240.            (IF (SCHI:SCHEME-SYMBOL-P (CAR D))
  241.                (STRING-CAPITALIZE (SYMBOL->STRING (CAR D)))
  242.                (CAR D))
  243.            .STREAM)
  244.          (MAPC
  245.            #'(LAMBDA (X) (WRITE-CHAR #\Space .STREAM) (.WRITE X .STREAM))
  246.            (CDR D))
  247.          (DISPLAY "}")))
  248. (SCHI:SET-VALUE-FROM-FUNCTION 'PRINT-RECORD
  249.                               'SCHEME::PRINT-RECORD)
  250. (LOCALLY (DECLARE (SPECIAL RECORD-DISCLOSERS))
  251.          (SETQ RECORD-DISCLOSERS (MAKE-HASH-TABLE)))
  252. (SCHI:SET-FUNCTION-FROM-VALUE 'RECORD-DISCLOSERS
  253.                               'SCHEME::RECORD-DISCLOSERS)
  254. (DEFUN DISCLOSE-RECORD
  255.        (RECORD)
  256.        (DECLARE (SPECIAL DEFAULT-RECORD-DISCLOSER
  257.                          RECORD-DISCLOSERS))
  258.        (FUNCALL
  259.          (GETHASH (RECORD-TYPE RECORD)
  260.                   RECORD-DISCLOSERS
  261.                   DEFAULT-RECORD-DISCLOSER)
  262.          RECORD))
  263. (SCHI:SET-VALUE-FROM-FUNCTION 'DISCLOSE-RECORD
  264.                               'SCHEME::DISCLOSE-RECORD)
  265. (DEFUN DEFAULT-RECORD-DISCLOSER
  266.        (RECORD)
  267.        (LIST (RTD-IDENTIFICATION (RECORD-TYPE RECORD))))
  268. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFAULT-RECORD-DISCLOSER
  269.                               'SCHEME::DEFAULT-RECORD-DISCLOSER)
  270. (DEFUN DEFINE-RECORD-DISCLOSER
  271.        (RTD PROC)
  272.        (DECLARE (SPECIAL RECORD-DISCLOSERS))
  273.        (SETF (GETHASH RTD RECORD-DISCLOSERS)
  274.              PROC))
  275. (SCHI:SET-VALUE-FROM-FUNCTION 'DEFINE-RECORD-DISCLOSER
  276.                               'SCHEME::DEFINE-RECORD-DISCLOSER)
  277.