;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:CPTFONT -*- ;; ;; (C) Copyright 1982 Massachusetts Institute of Technology ;; ;; Permission to use, copy, modify, distribute, and sell this software ;; and its documentation for any purpose is hereby granted without fee, ;; provided that the above copyright notice appear in all copies and that ;; both that copyright notice and this permission notice appear in ;; supporting documentation, and that the name of M.I.T. not be used in ;; advertising or publicity pertaining to distribution of the software ;; without specific, written prior permission. M.I.T. makes no ;; representations about the suitability of this software for any ;; purpose. It is provided "as is" without express or implied warranty. ;; ;; ;; This file is part of the BOXER system. ;; ;; Evaluator utility functions. ;;; Define BOXER-FUNCTION-SPECs. Boxer-function-specs have one of the ;;; following forms: ;;; (:BOXER-FUNCTION ) ;;; (:BOXER-FUNCTION ) ;;; ;;; Note that we need to have this a compile load and eval times!! (EVAL-WHEN (COMPILE LOAD EVAL) (PUTPROP ':BOXER-FUNCTION 'BOXER-FUNCTION-SPEC-HANDLER 'SYS:FUNCTION-SPEC-HANDLER) (DEFUN BOXER-FUNCTION-SPEC-HANDLER (OP FUNCTION-SPEC &OPTIONAL ARG1 ARG2) (LET ((SYMBOL-OR-BOX (CADR FUNCTION-SPEC))) (SELECTQ OP (SI:VALIDATE-FUNCTION-SPEC (OR (SYMBOLP SYMBOL-OR-BOX) (DOIT-BOX? SYMBOL-OR-BOX))) (SI:FDEFINE (COND ((SYMBOLP SYMBOL-OR-BOX) ;; If its a symbol, we put the function ;; in its value cell, and add the symbol ;; to the list of *boxer-functions*. (SET SYMBOL-OR-BOX ARG1) (UNLESS (MEMQ SYMBOL-OR-BOX *BOXER-FUNCTIONS*) (PUSH SYMBOL-OR-BOX *BOXER-FUNCTIONS*))) (T ;; If its a doit-box, we put the function ;; in the cached-code slot of the doit-box. (SEND SYMBOL-OR-BOX ':SET-CACHED-CODE ARG1)))) (SI:FDEFINEDP (COND ((SYMBOLP SYMBOL-OR-BOX) (AND (BOUNDP SYMBOL-OR-BOX) (LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX))) (OR (FUNCTIONP SYMBOL-VALUE) ;(FDEFINEDP SYMBOL-VALUE) (BOXER-FUNCTION? SYMBOL-VALUE) (BOXER-FDEFINED? SYMBOL-VALUE))))) ((DOIT-BOX? SYMBOL-OR-BOX) T))) (SI:FDEFINITION (COND ((SYMBOLP SYMBOL-OR-BOX) (UNLESS (NOT (BOUNDP SYMBOL-OR-BOX)) (LET ((SYMBOL-VALUE (SYMEVAL SYMBOL-OR-BOX))) (COND ((AND (SYMBOLP SYMBOL-VALUE) (FDEFINEDP SYMBOL-VALUE)) (FDEFINITION SYMBOL-VALUE)) ((FUNCTIONP SYMBOL-VALUE) SYMBOL-VALUE) (T (BOXER-FDEFINITION SYMBOL-VALUE)))))) ((DOIT-BOX? SYMBOL-OR-BOX) (SEND SYMBOL-OR-BOX ':CODE)) (T (FERROR "Boxer-Fn-Spec Error.")))) (SI:FDEFINITION-LOCATION (IF (SYMBOLP SYMBOL-OR-BOX) (VALUE-CELL-LOCATION SYMBOL-OR-BOX) (TELL SYMBOL-OR-BOX ':CODE-LOCATION))) (SI:FUNDEFINE (IF (SYMBOLP SYMBOL-OR-BOX) (MAKUNBOUND SYMBOL-OR-BOX))) (OTHERWISE (SI:FUNCTION-SPEC-DEFAULT-HANDLER OP FUNCTION-SPEC ARG1 ARG2))))) (DEFMETHOD (DOIT-BOX :VALIDATE-FUNCTION-SPEC) () ':BOXER-FUNCTION) ;; BOXER-FUNCALL is funcall for boxer-functions ;; --Always use BOXER-FUNCALL!!! Always use BOXER-FUNCALL!!!-- ;; Note well that: ;; (BOXER-FUNCALL 'FOO ) ;; is not necessarily the same as: ;; (FUNCALL (BOXER-GET-ACTUAL-FUNCTION 'FOO) ) ;; --Never use ordinary funcall! Never use ordinary funcall!-- (DEFUN BOXER-FUNCALL (X &REST ARGS) (COND ((AND (SYMBOLP X) (FDEFINEDP X)) (APPLY X ARGS)) ((AND (SYMBOLP X) (NOT (POINTS-TO-SELF X))) (LEXPR-FUNCALL #'BOXER-FUNCALL (BOXER-SYMEVAL X) ARGS)) ((NOT (BOXER-FUNCTION? X)) (FERROR "~S is not a Boxer Function. " X)) (T (BOXER-APPLY X ARGS)))) ;;; Boxer primitives which are written in lisp ;;; we need to be able to get the function, the arglist, and the eval markers in the arglist ;;; for each arg as they are needed ;;; we should be able to optionally specify a box that we want the function to be installed ;;; inside of. This implies that we won't be able to stick needed info on the plist of ;;; the symbol since a function can have the same name in many different boxes. Also, ;;; by the time we are interested in getting the arglist information of a primitive, we will ;;; be dealing with function objects, the associated symbol has already been symeval'd (DEFSUBST FLAVORED-ARGLIST? (ARGLIST) (SUBSET #'LISTP ARGLIST)) (DEFMACRO DEFBOXER-LOCAL-FUNCTION (FN-NAME IN-BOX . ARGS) (LET ((DUMMY-NAME (INTERN-IN-BU-PACKAGE (STRING-APPEND FN-NAME "-INTERNAL" (GENSYM "-")))) (BINDING-NAME (INTERN-IN-BU-PACKAGE FN-NAME))) (IF (NULL (FLAVORED-ARGLIST? (CAR ARGS))) `(PROGN (COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME) '(LAMBDA ,(CAR ARGS) ,@(CDR ARGS))) (TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME)) `(PROGN (COMPILE '(:BOXER-FUNCTION ,DUMMY-NAME) '(LAMBDA ,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS)) ,@(CDR ARGS))) (SET-ARGS-TEMPLATE ,DUMMY-NAME ',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS))) (TELL ,IN-BOX :ADD-STATIC-VARIABLE-PAIR ',BINDING-NAME ,DUMMY-NAME))))) ;; this doesn't remove old entries in special arglist table on redefinition ;; flavored input templates should be stored with the function objects anyway... (DEFMACRO DEFBOXER-FUNCTION (FN-NAME . ARGS) (COND ((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS)) (BOXER-EDITOR-COMMAND? (CAR ARGS))) ;; this is doing the duty of SET-KEY `(PROGN 'COMPILE (RECORD-COMMAND-KEY ',(INTERN-IN-BU-PACKAGE FN-NAME) ',(CAR ARGS)) (DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS)))) ((AND (NOT (NULL (CAR ARGS))) (SYMBOLP (CAR ARGS))) ;; handle the DEFF like form of DEFBOXER-FUNCTION `(DEFF (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ',(CAR ARGS))) ((NULL (FLAVORED-ARGLIST? (CAR ARGS))) ;; normal use without flavored inputs `(DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) . ,ARGS)) (T ;; flavored inputs `(PROGN 'COMPILE ;; get rid of old entries in the flavored inputs table (WHEN (FDEFINEDP '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME))) (REMOVE-ARGS-TEMPLATE (FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME))))) (DEFUN (:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME)) ,(GET-ARG-NAMES-FROM-ARGLIST (CAR ARGS)) ,@(CDR ARGS)) ;; make a new entry in the flavored inputs table (SET-ARGS-TEMPLATE (FDEFINITION '(:BOXER-FUNCTION ,(INTERN-IN-BU-PACKAGE FN-NAME))) ',(GET-TEMPLATE-FROM-ARGLIST (CAR ARGS))))))) ) (DEFUN POINTS-TO-SELF (X) (AND (SYMBOLP X) (BOXER-BOUNDP X) (EQ X (BOXER-SYMEVAL X)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Keep this code around so that the parser will still work... ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Boxer evaluation utilities. (DEFUN BOXER-FDEFINED? (X) (or (EVAL-DOIT? X) (functionp x) (AND (symbolp x) (NOT (POINTS-TO-SELF X)) (AND (BOXER-BOUNDP X) (boxer-fdefined? (BOXER-SYMEVAL X)))))) ;probably this should be fixed in the function spec handler, but that's about ;to be flushed... (DEFUN BOXER-FDEFINITION (X) (IF (POINTS-TO-SELF X) (FERROR "~S is not a valid Boxer function." x)) (AND (OR (SYMBOLP X) (DOIT-BOX? X)) (FDEFINITION `(:BOXER-FUNCTION ,X)))) (DEFF BOXER-GET-ACTUAL-FUNCTION 'BOXER-FDEFINITION) ;;same as in EVAL (DEFUN BOXER-FUNCTION? (THING) (OR (EVAL-DOIT? THING) (FUNCTIONP THING) (AND (EVAL-PORT? THING) (EVAL-DOIT? (GET-PORT-TARGET THING))))) ;;The error-detecting mechanism is somewhat of a crock. This stuff is done ;;so that the toplevel name (rather than one of its value's value's...) can ;;be reported. (DEFUN BOXER-ARGLIST (X) (LET ((RESULT (*CATCH 'BOXER-ARGLIST-BAD-FUNCTION (BOXER-ARGLIST-1 X)))) (IF (STRINGP RESULT) (FERROR RESULT X) RESULT))) (DEFUN BOXER-ARGLIST-1 (X) (LET ((TYPE (TYPEP X))) (COND ((POINTS-TO-SELF X) (*THROW 'BOXER-ARGLIST-BAD-FUNCTION "~S IS NOT A BOXER FUNCTION.")) ((EQ TYPE 'DOIT-BOX) (PARSER-BOXER-ARGLIST X)) ((FUNCTIONP X) (ARGLIST X)) ((EQ TYPE :SYMBOL) (BOXER-ARGLIST-1 (BOXER-SYMEVAL X))) (T (*THROW 'BOXER-ARGLIST-BAD-FUNCTION "~S IS NOT A BOXER FUNCTION"))))) #+LMITI (deff args-info-from-lambda-list 'si:args-info-from-lambda-list) ;;Evaluator insures that x will be a function object so we don't have to worry about symbols (DEFUN BOXER-ARGS-INFO (X) (ARGS-INFO-FROM-LAMBDA-LIST (ARGLIST X))) ;;; old parser stuff ;(defmethod (doit-box :funcall) (args) ; (let ((*currently-executing-box* self)) ; (with-dynamic-values-bound (make-frame self args) ; (cond (*step-flag* ; (let ((*step-flag* *step-flag*)) ; (step-through-box *box-copy-for-stepping*))) ;crock global register ; (t (funcall (tell self :code))))))) ;;;;stuff for minimal error handling. ;;this should probably be changed to handle printing the error specially, ;;instead of just returning it as a string, but we're going to have to ;;write something special anyway as an error handler, so maybe it will ;;fit in here unmolested and just *throw out if it feels like it. ;(defun eval-row-catching-errors (row) ; (if *boxer-error-handler-p* ; (condition-case (error) ; (eval (parse-into-code row)) ; (error ; (tell error :report-string))) ; (eval (parse-into-code row))))