home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / fnctns.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  9.4 KB  |  237 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*-
  2. ;;
  3. ;; (C) Copyright 1982 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. ;; This file is part of the BOXER system.
  17. ;;
  18. ;; Evaluator utility functions.
  19.  
  20. ;;; Define BOXER-FUNCTION-SPECs. Boxer-function-specs have one of the
  21. ;;; following forms: 
  22. ;;;   (:BOXER-FUNCTION <symbol>)
  23. ;;;   (:BOXER-FUNCTION <a doit box>)
  24. ;;;
  25. ;;; Note that we need to have this a compile load and eval times!!
  26.  
  27. (EVAL-WHEN (COMPILE LOAD EVAL)
  28.  
  29. (PUTPROP ':BOXER-FUNCTION 'BOXER-FUNCTION-SPEC-HANDLER 'SYS:FUNCTION-SPEC-HANDLER)
  30. (DEFUN BOXER-FUNCTION-SPEC-HANDLER (OP FUNCTION-SPEC &OPTIONAL ARG1 ARG2)
  31.   (LET ((SYMBOL-OR-BOX (CADR FUNCTION-SPEC)))
  32.     (SELECTQ OP
  33.       (SI:VALIDATE-FUNCTION-SPEC (OR (SYMBOLP SYMBOL-OR-BOX)
  34.                      (DOIT-BOX? SYMBOL-OR-BOX)))
  35.       (SI:FDEFINE                (COND ((SYMBOLP SYMBOL-OR-BOX)
  36.                     ;; If its a symbol, we put the function
  37.                     ;; in its value cell, and add the symbol
  38.                     ;; to the list of *boxer-functions*.
  39.                     (SET SYMBOL-OR-BOX ARG1)
  40.                     (UNLESS (MEMQ SYMBOL-OR-BOX *BOXER-FUNCTIONS*)
  41.                       (PUSH SYMBOL-OR-BOX *BOXER-FUNCTIONS*)))
  42.                        (T
  43.                     ;; If its a doit-box, we put the function
  44.                     ;; in the cached-code slot of the doit-box.
  45.                     (SEND SYMBOL-OR-BOX ':SET-CACHED-CODE ARG1))))
  46.       (SI:FDEFINEDP              (COND ((SYMBOLP SYMBOL-OR-BOX)
  47.                     (AND (BOUNDP SYMBOL-OR-BOX)
  48.                          (LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX)))
  49.                            (OR (FUNCTIONP SYMBOL-VALUE)
  50.                           ;(FDEFINEDP SYMBOL-VALUE)
  51.                            (BOXER-FUNCTION? SYMBOL-VALUE)
  52.                            (BOXER-FDEFINED? SYMBOL-VALUE)))))
  53.                        ((DOIT-BOX? SYMBOL-OR-BOX)
  54.                     T)))
  55.       (SI:FDEFINITION            (COND ((SYMBOLP SYMBOL-OR-BOX)
  56.                     (UNLESS (NOT (BOUNDP SYMBOL-OR-BOX))
  57.                       (LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX)))
  58.                         (COND ((AND (SYMBOLP SYMBOL-VALUE)
  59.                             (FDEFINEDP SYMBOL-VALUE))
  60.                            (FDEFINITION SYMBOL-VALUE))
  61.                           ((FUNCTIONP SYMBOL-VALUE) SYMBOL-VALUE)
  62.                           (T
  63.                            (BOXER-FDEFINITION SYMBOL-VALUE))))))
  64.                        ((DOIT-BOX? SYMBOL-OR-BOX)
  65.                     (SEND SYMBOL-OR-BOX ':CODE))
  66.                        (T
  67.                     (FERROR "Boxer-Fn-Spec Error."))))
  68.       (SI:FDEFINITION-LOCATION   (IF (SYMBOLP SYMBOL-OR-BOX)
  69.                      (VALUE-CELL-LOCATION SYMBOL-OR-BOX)
  70.                      (TELL SYMBOL-OR-BOX ':CODE-LOCATION)))
  71.       (SI:FUNDEFINE              (IF (SYMBOLP SYMBOL-OR-BOX)
  72.                      (MAKUNBOUND SYMBOL-OR-BOX)))
  73.       (OTHERWISE
  74.        (SI:FUNCTION-SPEC-DEFAULT-HANDLER OP FUNCTION-SPEC ARG1 ARG2)))))
  75.  
  76. (DEFMETHOD (DOIT-BOX :VALIDATE-FUNCTION-SPEC) ()
  77.   ':BOXER-FUNCTION)
  78.  
  79. ;; BOXER-FUNCALL is funcall for boxer-functions
  80. ;; --Always use BOXER-FUNCALL!!!        Always use BOXER-FUNCALL!!!--
  81. ;;       Note well that:
  82. ;;         (BOXER-FUNCALL 'FOO <args>)
  83. ;;       is not necessarily the same as:
  84. ;;         (FUNCALL (BOXER-GET-ACTUAL-FUNCTION 'FOO) <args>)
  85. ;; --Never use ordinary funcall!        Never use ordinary funcall!--
  86.  
  87. (DEFUN BOXER-FUNCALL (X &REST ARGS)
  88.   (COND ((AND (SYMBOLP X) (FDEFINEDP X)) (APPLY X ARGS))
  89.     ((AND (SYMBOLP X) (NOT (POINTS-TO-SELF X)))
  90.      (LEXPR-FUNCALL #'BOXER-FUNCALL (BOXER-SYMEVAL X) ARGS))
  91.     ((NOT (BOXER-FUNCTION? X))
  92.      (FERROR "~S is not a Boxer Function. " X))
  93.     (T (BOXER-APPLY X ARGS))))
  94.  
  95.  
  96.  
  97. ;;; Boxer primitives which are written in lisp
  98. ;;; we need to be able to get the function, the arglist, and the eval markers in the arglist
  99. ;;; for each arg as they are needed
  100. ;;; we should be able to optionally specify a box that we want the function to be installed
  101. ;;; inside of.  This implies that we won't be able to stick needed info on the plist of 
  102. ;;; the symbol since a function can have the same name in many different boxes.  Also,
  103. ;;; by the time we are interested in getting the arglist information of a primitive, we will
  104. ;;; be dealing with function objects, the associated symbol has already been symeval'd
  105.  
  106. (DEFSUBST FLAVORED-ARGLIST? (ARGLIST)
  107.   (SUBSET #'LISTP ARGLIST))
  108.  
  109. (DEFMACRO DEFBOXER-LOCAL-FUNCTION (FN-NAME IN-BOX . ARGS)
  110.   (LET ((DUMMY-NAME (INTERN-IN-BU-PACKAGE (STRING-APPEND FN-NAME "-INTERNAL" (GENSYM "-"))))
  111.     (BINDING-NAME (INTERN-IN-BU-PACKAGE FN-NAME)))
  112.     (IF (NULL (FLAVORED-ARGLIST? (CAR ARGS)))
  113.     `(PROGN
  114.        (COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME)
  115.             '(LAMBDA ,(CAR ARGS) ,@(CDR ARGS)))
  116.        (TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME))
  117.     `(PROGN
  118.        (COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME)
  119.             '(LAMBDA ,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS))
  120.                ,@(CDR ARGS)))
  121.        (SET-ARGS-TEMPLATE ,DUMMY-NAME ',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS)))
  122.        (TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME)))))
  123.  
  124. ;; this doesn't remove old entries in special arglist table on redefinition
  125. ;; flavored input templates should be stored with the function objects anyway...
  126. (DEFMACRO DEFBOXER-FUNCTION (FN-NAME . ARGS)
  127.   (COND
  128.     ((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS)) (BOXER-EDITOR-COMMAND? (CAR ARGS)))
  129.      ;; this is doing the duty of SET-KEY
  130.      `(PROGN 'COMPILE
  131.          (RECORD-COMMAND-KEY ',(INTERN-IN-BU-PACKAGE FN-NAME) ',(CAR ARGS))
  132.          (DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS))))
  133.     ((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS)))
  134.      ;; handle the DEFF like form of DEFBOXER-FUNCTION
  135.      `(DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS)))
  136.     ((NULL (FLAVORED-ARGLIST? (CAR ARGS)))
  137.      ;; normal use without flavored inputs
  138.      `(DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) . ,ARGS))
  139.     (T
  140.      ;; flavored inputs
  141.      `(PROGN 'COMPILE
  142.          ;; get rid of old entries in the flavored inputs table
  143.          (WHEN (FDEFINEDP '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))
  144.            (REMOVE-ARGS-TEMPLATE
  145.          (FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))))
  146.          (DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME))
  147.             ,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS))
  148.             ,@(CDR ARGS))
  149.          ;; make a new entry in the flavored inputs table
  150.          (SET-ARGS-TEMPLATE
  151.            (FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)))
  152.            ',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS)))))))
  153. )
  154.  
  155.  
  156.  
  157. (DEFUN POINTS-TO-SELF (X)
  158.   (AND (SYMBOLP X) (BOXER-BOUNDP X) (EQ X (BOXER-SYMEVAL X))))
  159.  
  160. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  161. ;;;     Keep this code around so that the parser will still work...                        ;;;
  162. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  163.  
  164. ;;;; Boxer evaluation utilities.
  165.  
  166. (DEFUN BOXER-FDEFINED? (X)
  167.   (or (EVAL-DOIT? X) (functionp x)
  168.       (AND (symbolp x)
  169.        (NOT (POINTS-TO-SELF X))
  170.        (AND (BOXER-BOUNDP X) (boxer-fdefined? (BOXER-SYMEVAL X))))))
  171. ;probably this should be fixed in the function spec handler, but that's about
  172. ;to be flushed...
  173.  
  174. (DEFUN BOXER-FDEFINITION (X)
  175.   (IF (POINTS-TO-SELF X) (FERROR "~S is not a valid Boxer function." x))
  176.   (AND (OR (SYMBOLP X) (DOIT-BOX? X))
  177.        (FDEFINITION `(:BOXER-FUNCTION ,X))))
  178.  
  179. (DEFF BOXER-GET-ACTUAL-FUNCTION 'BOXER-FDEFINITION)
  180.  
  181. ;;same as in EVAL
  182. (DEFUN BOXER-FUNCTION? (THING)
  183.   (OR (EVAL-DOIT? THING) (FUNCTIONP THING)
  184.       (AND (EVAL-PORT? THING) (EVAL-DOIT? (GET-PORT-TARGET THING)))))
  185.  
  186. ;;The error-detecting mechanism is somewhat of a crock.  This stuff is done
  187. ;;so that the toplevel name (rather than one of its value's value's...) can
  188. ;;be reported.
  189. (DEFUN BOXER-ARGLIST (X)
  190.   (LET ((RESULT (*CATCH 'BOXER-ARGLIST-BAD-FUNCTION
  191.           (BOXER-ARGLIST-1 X))))
  192.     (IF (STRINGP RESULT) (FERROR RESULT X)
  193.      RESULT)))
  194.  
  195. (DEFUN BOXER-ARGLIST-1 (X)
  196.   (LET ((TYPE (TYPEP X)))
  197.     (COND ((POINTS-TO-SELF X) (*THROW 'BOXER-ARGLIST-BAD-FUNCTION
  198.                       "~S IS NOT A BOXER FUNCTION."))
  199.       ((EQ TYPE 'DOIT-BOX) (PARSER-BOXER-ARGLIST X))
  200.       ((FUNCTIONP X) (ARGLIST X))
  201.       ((EQ TYPE :SYMBOL) (BOXER-ARGLIST-1 (BOXER-SYMEVAL X)))
  202.       (T (*THROW 'BOXER-ARGLIST-BAD-FUNCTION "~S IS NOT A BOXER FUNCTION")))))
  203.  
  204. #+LMITI
  205. (deff args-info-from-lambda-list 'si:args-info-from-lambda-list)
  206.  
  207. ;;Evaluator insures that x will be a function object so we don't have to worry about symbols
  208. (DEFUN BOXER-ARGS-INFO (X)
  209.   (ARGS-INFO-FROM-LAMBDA-LIST (ARGLIST X)))
  210.  
  211.  
  212. ;;; old parser stuff
  213. ;(defmethod (doit-box :funcall) (args)
  214. ;  (let ((*currently-executing-box* self))
  215. ;    (with-dynamic-values-bound (make-frame self args)
  216. ;      (cond (*step-flag*
  217. ;         (let ((*step-flag* *step-flag*))
  218. ;           (step-through-box *box-copy-for-stepping*)))    ;crock global register
  219. ;        (t (funcall (tell self :code)))))))
  220.  
  221.  
  222. ;;;;stuff for minimal error handling.
  223.  
  224. ;;this should probably be changed to handle printing the error specially,
  225. ;;instead of just returning it as a string, but we're going to have to
  226. ;;write something special anyway as an error handler, so maybe it will
  227. ;;fit in here unmolested and just *throw out if it feels like it.
  228.  
  229. ;(defun eval-row-catching-errors (row)
  230. ;  (if *boxer-error-handler-p*
  231. ;      (condition-case (error)
  232. ;      (eval (parse-into-code row))
  233. ;    (error
  234. ;      (tell error :report-string)))
  235. ;      (eval (parse-into-code row))))
  236.  
  237.