From 6b7149373610ba7b1df60ac521b05615b78a42ae Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Wed, 3 Oct 1990 15:15:55 +0000 Subject: [PATCH] Changed DEFOPERATOR to represent the function definition of an operator as a closure rather than as a function that must be compiled for each operator. --- code/alieneval.lisp | 61 +++++++++++++++++++++++---------------------- 1 file changed, 31 insertions(+), 30 deletions(-) diff --git a/code/alieneval.lisp b/code/alieneval.lisp index bae826d8c..4c9cc3d2d 100644 --- a/code/alieneval.lisp +++ b/code/alieneval.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.4 1990/10/03 15:01:15 ram Exp $ +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.5 1990/10/03 15:15:55 ram Exp $ ;;; ;;; This file contains any the part of the Alien implementation that ;;; is not part of the compiler. @@ -315,8 +315,8 @@ ,(length args) ',arg-types ',result-type)) (setf (info function source-transform ',name) #'c::alien=>lisp-transform) - (defun ,name (&rest dummy-arglist) - (displace-operator-definition ',name dummy-arglist)))) + (setf (fdefinition ',name) + (make-operator-definition ',name)))) (cond ((symbolp (car arg)) (push (car arg) argnames)) @@ -743,38 +743,39 @@ type)) -;;; Displace-Operator-Definition -- Internal +;;; MAKE-OPERATOR-DEFINITION -- Internal ;;; ;;; To save space and load & compile time for defoperators, we don't -;;; actually generate the function for the operator until it is called. -;;; This results in a significant space savings at the cost of -;;; always running the operator definition interpreted when called -;;; that way. -;;; -(defun displace-operator-definition (name actual-args) - (let ((info (info function alien-operator name))) - (unless info - (error "Operator ~S has no Alien-Operator-Info property.")) - (let ((num-args (alien-info-num-args info)) - (arg-types (alien-info-arg-types info))) - (do ((i 0 (1+ i)) - (args ()) - (binds ())) - ((= i num-args) - (let* ((args (nreverse args)) - (res (coerce `(lambda ,args - (alien-bind ,(nreverse binds) +;;; actually generate the function for the operator until it is called. This +;;; function returns a closure that, when called, computes the definition and +;;; installs as the definition of Name. This results in a significant space +;;; savings at the cost of always running the operator definition interpreted +;;; when called that way. +;;; +(defun make-operator-definition (name) + #'(lambda (&rest actual-args) + (let ((info (info function alien-operator name))) + (unless info + (error "Operator ~S has no Alien-Operator-Info property.")) + (let ((num-args (alien-info-num-args info)) + (arg-types (alien-info-arg-types info))) + (collect ((args) + (binds)) + (dotimes (i num-args) + (let ((type (assoc i arg-types)) + (sym (gensym))) + (args sym) + (when type + (binds `(,sym ,sym ,(cdr type)))))) + + (let ((res (coerce `(lambda ,(args) + (alien-bind ,(binds) (assert-alien-type - ,(apply (alien-info-function info) args) + ,(apply (alien-info-function info) (args)) ',(alien-info-result-type info)))) 'function))) - (setf (symbol-function name) res) - (apply res actual-args))) - (let ((type (assoc i arg-types)) - (sym (gensym))) - (push sym args) - (if type - (push `(,sym ,sym ,(cdr type)) binds))))))) + (setf (fdefinition name) res) + (apply res actual-args))))))) ;;;; Alien access method definition: -- GitLab