From 908f36adcb71be9b0391cd562d72d969be16e3ef Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 27 Oct 1994 01:43:51 +0000 Subject: [PATCH] Frobbed eval-when compile hackery of *class-table* so that the same updates are done at load-time. This way we have a valid table in case someone calls the build-toolkit-interface without having compiled this file. --- motif/lisp/prototypes.lisp | 130 ++++++++++++++++++++----------------- 1 file changed, 72 insertions(+), 58 deletions(-) diff --git a/motif/lisp/prototypes.lisp b/motif/lisp/prototypes.lisp index c6dfe8680..3c58cef0c 100644 --- a/motif/lisp/prototypes.lisp +++ b/motif/lisp/prototypes.lisp @@ -15,8 +15,16 @@ (in-package "TOOLKIT") +;;; This table is accessed at compile time so that we know the request ID as a +;;; numeric constant, and thus don't have to close over it at load time. The +;;; same updates are done in parallel at compile and load time. +;;; +(eval-when (compile load eval) + (defparameter *request-table* + (make-array 50 :element-type 'simple-string + :adjustable t :fill-pointer 0))) + (declaim (vector *request-table*)) -(eval-when (compile) (setf (fill-pointer *request-table*) 0)) @@ -30,67 +38,73 @@ (let ((arg-list (mapcar #'car args)) (type-list (mapcar #'cadr args)) (code (fill-pointer *request-table*))) - (vector-push-extend (format nil "R~a" string-name) *request-table*) - `(defun ,symbol-name ,arg-list - ,doc-string - ;; *** This generates lots of warnings at the moment - ;; (declare (inline toolkit-write-value)) - ,(cons 'declare - (mapcar #'(lambda (arg type) (list 'type type arg)) - arg-list type-list)) - (let ((message (prepare-request ,code ,options ,(length args)))) - ,(cons 'progn - (mapcar #'(lambda (arg) - (let ((name (first arg)) - (type (third arg))) - (if type - (list 'toolkit-write-value 'message name type) - (list 'toolkit-write-value 'message name)))) - args)) - (let ((reply (send-request-to-server message ,options))) - ,(if (eq options :confirm) - `(multiple-value-prog1 - ,(ecase (length return) - (0) - (1 `(let ((result (toolkit-read-value reply))) - ,@forms - result)) - (2 `(let* ((first (toolkit-read-value reply)) - (second (toolkit-read-value reply))) - ,@forms - (values first second))) - (3 `(let* ((first (toolkit-read-value reply)) - (second (toolkit-read-value reply)) - (third (toolkit-read-value reply))) - ,@forms - (values first second third))) - (4 `(let* ((first (toolkit-read-value reply)) - (second (toolkit-read-value reply)) - (third (toolkit-read-value reply)) - (fourth (toolkit-read-value reply))) - ,@forms - (values first second third fourth)))) - (destroy-message reply)) - '(declare (ignore reply)))))))) -) ;; EVAL-WHEN + `(progn + (eval-when (compile load eval) + (vector-push-extend (format nil "R~a" string-name) *request-table*)) + (defun ,symbol-name ,arg-list + ,doc-string + ;; *** This generates lots of warnings at the moment + ;; (declare (inline toolkit-write-value)) + ,(cons 'declare + (mapcar #'(lambda (arg type) (list 'type type arg)) + arg-list type-list)) + (let ((message (prepare-request ,code ,options ,(length args)))) + ,(cons 'progn + (mapcar #'(lambda (arg) + (let ((name (first arg)) + (type (third arg))) + (if type + (list 'toolkit-write-value 'message + name type) + (list 'toolkit-write-value 'message name)))) + args)) + (let ((reply (send-request-to-server message ,options))) + ,(if (eq options :confirm) + `(multiple-value-prog1 + ,(ecase (length return) + (0) + (1 `(let ((result (toolkit-read-value reply))) + ,@forms + result)) + (2 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply))) + ,@forms + (values first second))) + (3 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply)) + (third (toolkit-read-value reply))) + ,@forms + (values first second third))) + (4 `(let* ((first (toolkit-read-value reply)) + (second (toolkit-read-value reply)) + (third (toolkit-read-value reply)) + (fourth (toolkit-read-value reply))) + ,@forms + (values first second third fourth)))) + (destroy-message reply)) + '(declare (ignore reply))))))))) ;;; This is for sending commands to the server, not requesting Motif ;;; services. These calls take no arguments and return a value indicating ;;; whether they were successful. -(eval-when (compile eval) - (defmacro def-toolkit-command (symbol-name options &body forms) - (let ((string-name (symbol-class symbol-name)) - (code (fill-pointer *request-table*))) - (vector-push-extend string-name *request-table*) - `(defun ,symbol-name () - (let* ((message (prepare-request ,code ,options 0)) - (reply (send-request-to-server message ,options))) - ,(if (eq options :confirm) - `(let ((result (toolkit-read-value reply))) - (destroy-message reply) - ,@forms - result) - '(declare (ignore reply)))))))) + +(defmacro def-toolkit-command (symbol-name options &body forms) + (let ((string-name (symbol-class symbol-name)) + (code (fill-pointer *request-table*))) + `(progn + (eval-when (compile load eval) + (vector-push-extend string-name *request-table*) + (defun ,symbol-name () + (let* ((message (prepare-request ,code ,options 0)) + (reply (send-request-to-server message ,options))) + ,(if (eq options :confirm) + `(let ((result (toolkit-read-value reply))) + (destroy-message reply) + ,@forms + result) + '(declare (ignore reply))))))))) + +); eval-when (compile eval) -- GitLab