home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / evdefs.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  8.6 KB  |  278 lines
  1. ;-*- mode:lisp; package: Boxer; fonts: cptfont, cptfontb -*-
  2. #|
  3.             Copyright 1985 Massachusetts Institute of Technology
  4.  
  5.  Permission to use, copy, modify, distribute, and sell this software
  6.  and its documentation for any purpose is hereby granted without fee,
  7.  provided that the above copyright notice appear in all copies and that
  8.  both that copyright notice and this permission notice appear in
  9.  supporting documentation, and that the name of M.I.T. not be used in
  10.  advertising or publicity pertaining to distribution of the software
  11.  without specific, written prior permission.  M.I.T. makes no
  12.  representations about the suitability of this software for any
  13.  purpose.  It is provided "as is" without express or implied warranty.
  14.  
  15.  
  16.                                          +-Data--+
  17.                 This file is part of the | BOXER | system
  18.                                          +-------+
  19.  
  20.     This file contains the Definitions for objects used by the BOXER Evaluator
  21.     Variables particular to the Evaluator internals are declared here as well as 
  22.     some useful macros.
  23.  
  24. |#
  25.  
  26. ;;;; EvBox definitions
  27.  
  28. ;; Stores 2 representations of a row.  The ENTRIES slot is a list of the semantically 
  29. ;; interesting values while the ITEMS slot has those same entries interspersed with formatting
  30. ;; information. 
  31. ;; For Example:
  32. ;; A ROW that appears in BOXER as "[] foo  bar ; a comment
  33. ;; would have a corresponding EVROW with
  34. ;;    ENTRIES = ([] FOO BAR)     and 
  35. ;;    ITEMS   = ([] (:SPACES 1) FOO (:SPACES 2) BAR :SEMI-COLON-COMMENT A COMMENT)
  36. ;;
  37.  
  38. (DEFSTRUCT (EVROW (:TYPE :NAMED-ARRAY)
  39.           :COPIER
  40.           (:PREDICATE EVROW?)
  41.           (:CONC-NAME "EVROW-")
  42.           (:PRINT "#<EVROW ~A>" (PRINT-EVROW-INTERNAL EVROW)))
  43.   (ENTRIES '())
  44.   (ITEMS   '()))
  45.  
  46. (DEFSTRUCT (EVBOX (:TYPE :NAMED-ARRAY)
  47.          (:PREDICATE EVBOX?)
  48.          (:PRINT "#<~A>" (PRINT-EVBOX-INTERNAL EVBOX))
  49.          (:CONC-NAME "%EVBOX-"))
  50.   (NAME NIL)
  51.   (BINDINGS NIL)
  52.   (ROWS '(())))
  53.  
  54. (DEFSTRUCT (EVDOIT (:INCLUDE EVBOX)
  55.           :COPIER
  56.           (:PREDICATE EVDOIT?)
  57.           (:PRINT "#<~A>" (PRINT-EVBOX-INTERNAL EVDOIT))
  58.           :CONSTRUCTOR)
  59.   )
  60.  
  61. (DEFSTRUCT (EVDATA (:INCLUDE EVBOX)
  62.           :COPIER
  63.           (:PREDICATE EVDATA?)
  64.           (:PRINT "#<~A>" (PRINT-EVBOX-INTERNAL EVDATA))
  65.           :CONSTRUCTOR)
  66.   )
  67.  
  68. (DEFSTRUCT (EVPORT (:TYPE :NAMED-ARRAY)
  69.           (:PREDICATE EVPORT?)
  70.           (:PRINT "#<EvPORT ~A>" (EVPORT-TARGET EVPORT))
  71.           :CONSTRUCTOR
  72.           (:CONC-NAME "%EVPORT-")
  73.           :COPIER)
  74.   (NAME NIL)
  75.   (TARGET NIL))
  76.  
  77.  
  78.  
  79. ;;;; Constructors
  80.  
  81.  
  82. ;;; shadow out the DEFSTuct created one cause its not smart enough
  83. (DEFUN MAKE-EVDATA-FROM-ROWS (ROW-LIST)
  84.   (MAKE-EVDATA ROWS (MAPCAR #'MAKE-EVROW-FROM-ITEMS ROW-LIST)))
  85.  
  86. (DEFUN MAKE-EVROW-FROM-ENTRY (ENTRY)
  87.   (MAKE-EVROW ENTRIES (NCONS ENTRY)
  88.           ITEMS   (NCONS ENTRY)))
  89.  
  90. (DEFUN MAKE-EVROW-FROM-ENTRIES (ENTRIES)
  91.   (MAKE-EVROW ENTRIES ENTRIES
  92.           ITEMS ENTRIES))
  93.  
  94. (DEFUN MAKE-EVROW-FROM-ITEMS (ITEMS)
  95.   (MAKE-EVROW ENTRIES (PARSE-LIST-FOR-EVAL ITEMS)
  96.           ITEMS ITEMS))
  97.  
  98. (DEFUN APPEND-EVROWS (&REST EVROWS)
  99.   (MULTIPLE-VALUE-BIND (ENTRIES ITEMS)
  100.       (LOOP FOR EVROW IN EVROWS
  101.         APPENDING (AND EVROW (EVROW-ENTRIES EVROW)) INTO E
  102.         APPENDING (AND EVROW (EVROW-ITEMS   EVROW)) INTO I
  103.         FINALLY
  104.           (RETURN (VALUES E I)))
  105.   (MAKE-EVROW ENTRIES ENTRIES ITEMS ITEMS)))
  106.  
  107. (DEFSUBST MAKE-EMPTY-EVROW (&OPTIONAL (SPACES 0))
  108.   (MAKE-EVROW ITEMS (WHEN (> SPACES 0) (NCONS (MAKE-SPACES SPACES)))))
  109.  
  110.  
  111.  
  112. ;;;; Printing
  113.  
  114. (DEFUN PRINT-EVROW-INTERNAL (EVROW)
  115.   (LET ((ROW-ENTRIES (EVROW-ENTRIES EVROW)))
  116.     (FORMAT NIL "~A ~A ~A" (IF (NULL ROW-ENTRIES) "" (CAR ROW-ENTRIES))
  117.                        (IF (NULL (CADR ROW-ENTRIES)) "" (CADR ROW-ENTRIES))
  118.                (IF (NULL (CADDR ROW-ENTRIES)) "" "..."))))
  119.  
  120. (DEFUN PRINT-EVBOX-INTERNAL (EVBOX)
  121.   (FORMAT NIL "~A ~A" (TYPEP EVBOX) (LET ((1ST-ROW (CAR (EVBOX-ROWS EVBOX))))
  122.                       (COND ((NULL 1ST-ROW) "")
  123.                         ((EVROW? 1ST-ROW) (PRINT-EVROW-INTERNAL 1ST-ROW))
  124.                         (T "Bad Row")))))
  125.  
  126.  
  127. ;;;; Predicates
  128.  
  129. (DEFSUBST EVAL-BOX? (THING)
  130.   (OR (BOX? THING) (EVBOX? THING)))
  131.  
  132. (DEFSUBST EVAL-DOIT? (THING)
  133.   (OR (DOIT-BOX? THING) (EVDOIT? THING)))
  134.  
  135. (DEFSUBST EVAL-DATA? (THING)
  136.   (OR (DATA-BOX? THING) (EVDATA? THING)))
  137.  
  138. (DEFSUBST EVAL-PORT? (THING)
  139.   (OR (PORT-BOX? THING) (EVPORT? THING)))
  140.  
  141.  
  142.  
  143. ;;;; Accessor SUBSTs
  144.  
  145. (DEFSUBST EVBOX-NAME (EVBOX) (IF (EVPORT? EVBOX)
  146.                  (%EVPORT-NAME EVBOX)
  147.                  (%EVBOX-NAME EVBOX)))
  148.  
  149. (DEFSUBST EVBOX-BINDINGS (EVBOX) (IF (EVPORT? EVBOX)
  150.                      (GET-LOCAL-ENV (EVPORT-TARGET EVBOX))
  151.                      (%EVBOX-BINDINGS EVBOX)))
  152.  
  153. (DEFSUBST EVBOX-ROWS (EVBOX) (IF (EVAL-PORT? EVBOX) (FERROR "can't get the rows of a PORT")
  154.                  (%EVBOX-ROWS EVBOX)))
  155.  
  156. (DEFSUBST EVPORT-TARGET (EVPORT) (%EVPORT-TARGET EVPORT))
  157.  
  158. ;;; somewhat higher level row accessors
  159. (DEFSUBST EVBOX-ROW-ENTRIES (EVBOX)
  160.   (MAPCAR #'EVROW-ENTRIES (EVBOX-ROWS EVBOX)))
  161.  
  162. (DEFSUBST EVBOX-ROW-ITEMS (EVBOX)
  163.   (MAPCAR #'EVROW-ITEMS (EVBOX-ROWS EVBOX)))
  164.  
  165. ;;; mutator substs
  166.  
  167. (DEFSUBST SET-EVBOX-NAME (EVBOX NEW-NAME)
  168.   (IF (EVPORT? EVBOX) (SETF (%EVPORT-NAME EVBOX) NEW-NAME)
  169.       (SETF (%EVBOX-NAME EVBOX) NEW-NAME)))
  170.  
  171. (DEFSUBST SET-EVBOX-BINDINGS (EVBOX NEW-BINDINGS)
  172.   (IF (EVPORT? EVBOX) (SETF (%EVBOX-BINDINGS (EVPORT-TARGET EVBOX)) NEW-BINDINGS)
  173.   (SETF (%EVBOX-BINDINGS EVBOX) NEW-BINDINGS)))
  174.  
  175. (DEFUN SET-EVBOX-ROWS (EVBOX NEW-ROWS)
  176.   (IF (EVPORT? EVBOX)
  177.       (SET-EVBOX-ROWS (EVPORT-TARGET EVBOX) NEW-ROWS)
  178.       (SETF (%EVBOX-ROWS EVBOX) NEW-ROWS)))
  179.  
  180. #-LMITI(DEFPROP EVBOX-ROWS    ((EVBOX-ROWS EVBOX) SET-EVBOX-ROWS EVBOX SI:VAL) SETF)
  181.  
  182. #+LMITI(DEFSETF EVBOX-ROWS (EVBOX) (NEW-ROWS) `(SET-EVBOX-ROWS  ,EVBOX ,NEW-ROWS))
  183.  
  184. (DEFVAR *SPACING-INFO-SYMBOL* :SPACES)
  185.  
  186. ;;; comments
  187.  
  188. (DEFVAR *VERTICAL-BAR-COMMENT* :VERTICAL-BAR-COMMENT)
  189. (DEFVAR *SEMI-COLON-COMMENT*   :SEMI-COLON-COMMENT)
  190.  
  191. (PUTPROP *VERTICAL-BAR-COMMENT* #/| 'CONVERTED-CHARACTER)
  192. (PUTPROP *SEMI-COLON-COMMENT*   #/; 'CONVERTED-CHARACTER)
  193.  
  194. (DEFVAR *COMMENT-CHA-SYMBOLS* `(,*VERTICAL-BAR-COMMENT* ,*SEMI-COLON-COMMENT*))
  195.  
  196. (DEFVAR *FUNNY-FUNCTION-ARGLIST-TABLE* (MAKE-HASH-TABLE))
  197.  
  198. (DEFVAR *SYMBOLS-FOR-INPUT-LINE* '(BU: BU:INPUT BU:INPUTS))
  199.  
  200. (DEFVAR *EVALUATOR-COPYING-ON?* T
  201.   "A Flag which controls the automatic copying of objects in the evaluator.  ")
  202.  
  203. (DEFVAR *EVALUATOR-COPYING-FUNCTION* 'SHALLOW-COPY-FOR-EVALUATOR)
  204.  
  205. (DEFVAR *MULTIPLE-ROW-TOP-LEVEL-UNBOX-ACTION* :FLATTEN
  206.   "What happens when we unbox a box with multiple rows at top level. Valid values are
  207. :ERROR (signal an error), :TRUNCATE (use only the top row) and :FLATTEN (use each row
  208. sequentially). ")
  209.  
  210. ;;; Here are the special markers used to alter the default behavior of objects
  211. ;;; in the Evaluator
  212.  
  213. (DEFVAR EVAL-SPECIAL-MARKERS NIL
  214.   "A list of all the special markers used by the evaluator. ")
  215.  
  216. (DEFMACRO DEFINE-EVAL-MARKER-PREDICATE (NAME VALUE)
  217.   (LET ((PREDICATE-NAME (INTERN (FORMAT NIL "~A?" (GET-PNAME NAME)))))
  218.     `(DEFSUBST ,PREDICATE-NAME (MARKER)
  219.        (OR (EQ ',VALUE MARKER)
  220.        (AND (LISTP MARKER) (MEMQ ',VALUE MARKER))))))
  221.  
  222. (DEFMACRO DEFINE-MARKER-READER-MACRO (NAME VALUE CHA)
  223.   (WHEN (CHA? CHA)
  224.     (LET ((MACRO-NAME (INTERN (FORMAT NIL "BOXER-~A-READER-MACRO" (GET-PNAME NAME)))))
  225.       `(PROGN 'COMPILE
  226.           (SET-SYNTAX-MACRO-CHAR ,CHA ',MACRO-NAME *BOXER-READTABLE*)
  227.           (PUTPROP ,VALUE ,CHA 'CONVERTED-CHARACTER)
  228.           (DEFUN ,MACRO-NAME (LIST-SO-FAR IGNORE)
  229.           (VALUES (APPEND LIST-SO-FAR (NCONS ,VALUE)) NIL T))))))
  230.  
  231. (DEFMACRO DEFINE-EVAL-MARKER (NAME VALUE ACTION-TYPE &OPTIONAL (ALIASES NIL) (READER-CHA NIL))
  232.   `(PROGN 'COMPILE
  233.       (DOLIST (ALIAS ',(APPEND ALIASES (NCONS VALUE)))
  234.         (PUTPROP ALIAS ',VALUE :BOXER-INPUT-FLAVOR))
  235.       (DEFCONST ,NAME ',VALUE ',ACTION-TYPE)
  236.       (DEFINE-MARKER-READER-MACRO ,NAME ',VALUE ,READER-CHA)
  237.       (DEFPROP ,VALUE ,ACTION-TYPE :ACTION-TYPE)
  238.       (DEFINE-EVAL-MARKER-PREDICATE ,NAME ,VALUE)
  239.       (PUSH ',VALUE EVAL-SPECIAL-MARKERS)))
  240.  
  241.       
  242.  
  243. ;; for Ports
  244.  
  245. (DEFUN GET-PORT-TARGET (PORT)
  246.   (IF (PORT-BOX? PORT) (TELL PORT :PORTS)
  247.       (EVPORT-TARGET PORT)))
  248.  
  249. (DEFSUBST BOX-OR-PORT-TARGET (BOX-OR-PORT)
  250.   "Gets you something that is NOT a port"
  251.   (IF (EVAL-PORT? BOX-OR-PORT) (GET-PORT-TARGET BOX-OR-PORT) BOX-OR-PORT))
  252.  
  253. ;;; Insure that an EvBox is returned when selecting parts of an EvBox which is using 
  254. ;;; the shallow copying representation
  255.  
  256. (DEFMACRO GUARANTEE-COPY (BOX-OR-EVBOX)
  257.   `(IF (BOX? ,BOX-OR-EVBOX) (MAKE-EVBOX-FROM-BOX ,BOX-OR-EVBOX)
  258.        ,BOX-OR-EVBOX))
  259.  
  260.  
  261. ;;;; spaces and comments
  262.  
  263. ;;;; How to Deal with spaces and other irrelevant stuff
  264. ;;;  in this representation, spaces are represented by a CONS whose CAR is the value of
  265. ;;;  *SPACING-INFO-SYMBOL* and whose CDR is the number of spaces
  266.  
  267. (DEFSUBST MAKE-SPACES (N)
  268.   (CONS *SPACING-INFO-SYMBOL* N))
  269.  
  270. (DEFSUBST GET-SPACES (SPACER-ITEM)
  271.   (CDR SPACER-ITEM))
  272.  
  273. (DEFSUBST SPACES? (EVROW-ITEM)
  274.   (AND (LISTP EVROW-ITEM)(EQ (CAR EVROW-ITEM) *SPACING-INFO-SYMBOL*)))
  275.  
  276. (DEFSUBST COMMENT-CHA? (EVROW-ITEM)
  277.   (MEMQ EVROW-ITEM *COMMENT-CHA-SYMBOLS*))
  278.