head     1.1;
access   ;
symbols  ;
locks    ; strict;
comment  @@;


1.1
date     90.02.22.16.56.49;  author ram;  state Exp;
branches ;
next     ;


desc
@ Working code version as of 2/22/90.  
@



1.1
log
@Initial revision
@
text
@;;; -*- Mode: Lisp; Package: Extensions; Log: code.log -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@@CMUC). 
;;; **********************************************************************
;;;
;;; Macro to support interpreted calls to user miscops.
;;;
;;; Written and maintained by David B. McDonald
;;;

(in-package "EXTENSIONS")
(export 'call-user-miscop)

(defmacro call-user-miscop (name &rest args)
  (let ((fcn (get name '%miscop-function)))
    (when (null fcn)
      (let* ((mname (intern (symbol-name name) (find-package "COMPILER")))
	     (addr (get mname 'lisp::%loaded-address)))
	(when (null addr)
	  (error "Attempt to call user miscop ~A when it hasn't been loaded."
		 name))
	(let ((nname (make-symbol (concatenate 'simple-string
					       "CALL-USER-MISCOP-"
					       (symbol-name name))))
	      (fal (do ((al args (cdr al))
			(fal NIL))
		       ((null al) fal)
		     (push (gensym) fal))))
	  (setf (symbol-function nname)
		`(lambda ,fal
		   (block ,nname
		     (call-user-miscop ,mname ,@@fal))))
	  (compile nname)
	  (setf (get name '%miscop-function) nname)
	  (setq fcn nname))))
    `(funcall #',fcn ,@@args)))
@