Suppose we have two packages, each defines a class and exports symbols for slots/generic methods with identical names.
(defpackage pkg1 (:export _class1 _slot _reader _method))
(in-package pkg1)
(defclass _class1 () ((_slot :initform "SLOT111" :initarg :slot :reader _reader)))
(defmethod _method ((self _class1)) (format t "SLOT-: ~a~%" (_reader self)))
(defpackage pkg2 (:export _class2 _slot _reader _method))
(in-package pkg2)
(defclass _class2 () ((_slot :initform "SLOT222" :initarg :slot :reader _reader)))
(defmethod _method ((self _class2)) (format t "SLOT=: ~a~%" (_reader self)))
How do we import those symbols in some third package, successfully merging (not shadowing) generics?
(defpackage test)
(in-package test)
... ; here we somehow import symbols _slot, _reader and _method
; from both packages, so they get merged (like in 'GNU Guile' or 'Gauche')
(defvar v1 (make-instance '_class1))
(defvar v2 (make-instance '_class2))
(_reader v1) (_method v1) ; both must work
(_reader v2) (_method v2) ; and these too
I'm really a noob when it comes to CLOS so I did the same experiment last year. My findings is that CL doesn't really export methods or merge methods. It exports symbols, that might have bindings. Thus you need to make a package with the symbols that they should share and perhaps put the documentation there:
;; common symbols and documantation
(defpackage interface (:export _slot _reader _method))
(in-package interface)
(defgeneric _method (self)
(:documentation "This does this functionality"))
(defgeneric _reader (self)
(:documentation "This does that functionality"))
(defpackage pkg1 (:use :cl :interface) (:export _class1 _slot _reader _method))
(in-package pkg1)
(defclass _class1 () ((_slot :initform "SLOT111" :initarg :slot :reader _reader)))
(defmethod _method ((self _class1)) (format t "SLOT-: ~a~%" (_reader self)))
(defpackage pkg2 (:use :cl :interface) (:export _class2 _slot _reader _method))
(in-package pkg2)
(defclass _class2 () ((_slot :initform "SLOT222" :initarg :slot :reader _reader)))
(defmethod _method ((self _class2)) (format t "SLOT=: ~a~%" (_reader self)))
(defpackage test (:use :cl :pkg1 :pkg2))
(in-package test)
(defvar v1 (make-instance '_class1))
(defvar v2 (make-instance '_class2))
(_reader v1) ; ==> "SLOT111"
(_method v1) ; ==> nil (outputs "SLOT-: SLOT111")
(_reader v2) ; ==> "SLOT222"
(_method v2) ; ==> nil (outputs "SLOT-: SLOT222")
You can from test check out what has happened:
(describe '_method)
_METHOD is the symbol _METHOD, lies in #<PACKAGE INTERFACE>, is accessible in
4 packages INTERFACE, PKG1, PKG2, TEST, names a function.
Documentation as a FUNCTION:
This does this functionality
#<PACKAGE INTERFACE> is the package named INTERFACE.
It imports the external symbols of 1 package COMMON-LISP and
exports 3 symbols to 2 packages PKG2, PKG1.
#<STANDARD-GENERIC-FUNCTION _METHOD> is a generic function.
Argument list: (INTERFACE::SELF)
Methods:
(_CLASS2)
(_CLASS1)
(describe '_reader)
_READER is the symbol _READER, lies in #<PACKAGE INTERFACE>, is accessible in
4 packages INTERFACE, PKG1, PKG2, TEST, names a function.
Documentation as a FUNCTION:
This does that functionality
#<PACKAGE INTERFACE> is the package named INTERFACE.
It imports the external symbols of 1 package COMMON-LISP and
exports 3 symbols to 2 packages PKG2, PKG1.
#<STANDARD-GENERIC-FUNCTION _READER> is a generic function.
Argument list: (INTERFACE::SELF)
Methods:
(_CLASS2)
(_CLASS1)
This has the side effect that importing pkg1 _method will work on pkg2 instances should you get such instance from a package that uses pkg2.
Now there is an elephant in this room. Why not define a base class in interface and add it as the parent class of both _class1 and _class2. You can easily do that with just a few changes, however that wasn't what you asked for.
After trying to solve this task via MOP I came up with a much simplier workaround:
(defmacro wrapping-import
(sym-name &rest sym-list)
`(defmethod ,sym-name
(&rest args)
(loop for sym in '(,#sym-list) do
(let ((gf (symbol-function sym)))
(if (compute-applicable-methods gf args)
(return (apply gf args)))))
(error "No applicable method found in ~A" ',sym-name)))
Example:
(defpackage p1 (:export say-type))
(in-package p1)
(defmethod say-type ((v integer)) "int")
(defpackage p2 (:export say-type))
(in-package p2)
(defmethod say-type ((v string)) "str")
(in-package cl-user)
(wrapping-import say-type p1:say-type p2:say-type)
(say-type "") ; -> "str"
(say-type 1) ; -> "int"
Also, here's the original solution:
(defmacro merging-import
(sym-name &rest sym-list)
(let ((gf-args (clos:generic-function-lambda-list
(symbol-function (first sym-list)))))
`(progn
(defgeneric ,sym-name ,gf-args)
(loop for sym in '(,#sym-list) do
(loop for meth
in (clos:generic-function-methods (symbol-function sym))
do
(add-method #',sym-name
(make-instance 'clos:standard-method
:lambda-list (clos:method-lambda-list meth)
:specializers (clos:method-specializers meth)
:function (clos:method-function meth))))))))
Note that wrapping-import works even when signatures of generic functions don't match, while merging-import requires their lambda-lists to be equal.
Now I wonder: why we have to invent such things in 2017? Why those aren't in the standard yet?
And just in case someone needs it - a macro, which works like from pkg import * in Python:
(defmacro use-all-from
(&rest pkg-list)
`(loop for pkg-name in '(,#pkg-list) do
(do-external-symbols
(sym (find-package pkg-name))
(shadowing-import (read-from-string (format nil "~a:~a"
pkg-name sym))))))
Related
I tried to construct a function template that I can use in other packages with package-specific parameters. The gist of what I tried to achieve this is as follows:
;;; FSM
(in-package #:fsm)
(defmacro %cas (flag old new)
#+sbcl `(sb-ext:compare-and-swap ,flag ,old ,new)
#+ecl `(mp:compare-and-swap ,flag ,old ,new)
)
(defmacro control! (fsm task flag)
`(let ((*task-category* (tag ,task)))
(unless (%cas ,flag nil t)
(lambda () (submit-task (channel (cqueue-prio-out ,fsm)) (fn ,task))))))
;;; REPL
(in-package #:repl)
(defparameter *controller-active* nil)
(control! fsm control-task *controller-active*)
;;; USB-SP
(in-package #:usb-sp)
(defparameter *controller-active* nil)
(control! fsm control-task *controller-active*)
Apparently, this does not work:
Unhandled SIMPLE-ERROR in thread #<SB-THREAD:THREAD "main thread" RUNNING {1001640703}>:
Invalid place to CAS: CNC-HOST/FSM::FLAG -> CNC-HOST/FSM::FLAG
How is this construct properly done?
After receiving feedback on the freenode lisp channel, it became clear to me that the macro construct works as intended:
(defpackage #:fsm (:use #:cl) (:export #:control!! #:%cas))
(defpackage #:repl (:use #:cl #:fsm) (:export #:test-in-repl))
(defpackage #:usb-sp (:use #:cl #:fsm) (:export #:test-in-usb-sp))
;;; FSM
(in-package #:fsm)
(defmacro %cas (flag old new)
#+sbcl `(sb-ext:compare-and-swap ,flag ,old ,new)
#+ecl `(mp:compare-and-swap ,flag ,old ,new))
(defmacro control!! (flag pkg)
`(lambda () (if (%cas ,flag nil t)
(format nil "~A : skip task" ,pkg)
(format nil "~A : task run" ,pkg))))
;;; REPL
(in-package #:repl)
(defparameter *controller-active* nil)
(defun test-in-repl (pkg) (funcall (control!! *controller-active* pkg)))
(assert (string= "repl : task run" (test-in-repl "repl")))
(assert *controller-active*)
;;; USB-SP
(in-package #:usb-sp)
(defparameter *controller-active* nil)
(defun test-in-usb-sp (pkg) (funcall (control!! usb-sp::*controller-active* pkg)))
(assert (string= "usb-sp : task run" (test-in-usb-sp "usb-sp")))
(assert *controller-active*)
(in-package #:cl-user)
(assert (string= "repl : skip task" (repl:test-in-repl "repl")))
(assert (string= "usb-sp : skip task" (usb-sp:test-in-usb-sp "usb-sp")))
The compiler message made me think that I had an error in the macros - instead I overlooked that in my use case control!! should have returned the function call result instead of the lambda.
I've a macro defined in package "a" that defines a function "fun". I'd like to use this macro in package "b" expecting to get "fun" defined in "b" but it ends up getting defined in "a". Can someone please help?
Here's the sample code:
(defpackage #:a (:use #:cl) (:export makefun))
(in-package #:a)
(defmacro makefun (&optional (name (package-name *package*)))
`(defun fun ()
,(format nil "hello ~a" name)))
(defpackage #:b (:use #:cl #:a))
(in-package #:b)
(macroexpand-1 '(makefun)) ; expands to (DEFUN A::FUN () "hello B")
(makefun)
(fun) ; fails
(defpackage #:c (:use #:cl #:a))
(in-package #:c)
(macroexpand-1 '(makefun)) ; expands to (DEFUN A::FUN () "hello C")
(makefun)
(fun) ; fails
If what you really want to do is have it making the function name in the dynamically-current package you want to do something like this:
(defmacro makefun (&optional (name (package-name *package*)))
(let ((funn (intern (symbol-name 'fun) *package*)))
`(defun ,funn ()
,(format nil "hello ~a" name))))
However this smells like an XY problem to me: I don't know what the problem you're trying to solve is but there is very likely to be a better solution than lots of different functions all with the same name but in different packages.
In Gambit Scheme, I can't seem to invoke a macro in the definition of another macro if I compile the file. Here is a contrived example:
;;;; example.scm
(define-macro (w/gensyms gs body)
`(let ,(map (lambda (g) `(,g (gensym ',g)))
gs)
,body))
(define-macro (compose-macro f g)
(w/gensyms (x)
`(lambda (,x) (,f (,g ,x)))))
(define my-cadr
(lambda (x)
((compose-macro car cdr) x)))
;; $ gsc example.scm
;; *** ERROR IN #<procedure #2> -- Unbound variable: w/gensyms
However, if I load the file with the (include ...) special form in the interpreter, it works
$ gsi
> (include "example.scm")
> (pp my-cadr)
(lambda (x) ((lambda (#:x0) (car (cdr #:x0))) x))
Does anyone know what is going on here? Can I convince Gambit to let me use w/gensyms in the definition of another macro in a compiled file?
This is most likely related to phases.
Try this:
Put w/gensyms in a file a.scm and put compose-macro in a file b.scm that imports a.scm.
This is a phasing problem. You want the definition of w/gensyms to be available in the body of subsequent macros. This can be achieved with a for-syntax macro that forces the evaluation of the macro definition at syntax expansion time:
(define-macro (for-syntax . body)
(eval `(begin ,#body))
`(begin))
(for-syntax
(define-macro (w/gensyms gs body)
`(let ,(map (lambda (g) `(,g (gensym ',g)))
gs)
,body)))
If you want the macro to be available both from within other macro definitions and within non-macro definition code you can use this instead:
(define-macro (for-syntax . body)
(eval `(begin ,#body))
`(begin ,#body))
For this specific example, since you are using the macro at a single place, you could have done this:
(define-macro (compose-macro f g)
(define-macro (w/gensyms gs body)
`(let ,(map (lambda (g) `(,g (gensym ',g)))
gs)
,body))
(w/gensyms (x)
`(lambda (,x) (,f (,g ,x)))))
A related approach to address phasing issues is to put the definition of w/gensyms and other macros in the file "macros.scm" and do:
(define-macro (compose-macro f g)
(include "macros.scm")
(w/gensyms (x)
`(lambda (,x) (,f (,g ,x)))))
I try to write a macro, which given a name could be supplied in the function myfunc to create a class and make an instance of this class.
Here is the code:
(defmacro define-class (class-name)
`(eval
`(progn
(defclass ,,class-name () ())
(make-instance ,class-name))))
(defun myfunc (name)
(define-class name))
I can compile successfully the macro but not the function. In this case I get a warning at compilation time saying that:
undefined variable: CLASS-NAME
If I modify a bit the macro so that instead of writing
(make-instance ,class-name)
I write
(make-instance ,,class-name)
Then in this case I can compile both, but when running (myfunc 'toto) I get the following error:
The variable TOTO is unbound.
I try to figure out how the macro is expanded with macroexpand-1. With the first macro which is defined with (make-instance ,class-name) it gave me the following result:
(EVAL `(PROGN (DEFCLASS ,'TOTO NIL NIL) (MAKE-INSTANCE ,CLASS-NAME)))
Whereas in the second macro which is defined with *(make-instance ,,class-name) it gave me the following result:
(EVAL `(PROGN (DEFCLASS ,'TOTO NIL NIL) (MAKE-INSTANCE ,'TOTO)))
But I guess the right expansion in my case would be something like:
(EVAL `(PROGN (DEFCLASS ,'TOTO NIL NIL) (MAKE-INSTANCE 'TOTO)))
How could I modify or re-write the macro so that it works?
You want to write code like this:
(defun myfunc (name)
(define-class name))
This would actually be similar to this:
(defun myfunc (name)
(let ((name name))
(eval `(defclass ,name () ()))
(make-instance name)))
Thus the DEFINE-CLASS macro should generate something like above code.
(defmacro define-class (name)
(let ((name-sym (gensym "CLASS-NAME")))
`(let ((,name-sym ,name))
(eval `(defclass ,,name-sym () ()))
(make-instance ,name-sym))))
Using it:
CL-USER 21 > (pprint (macroexpand-1 '(define-class name)))
(LET ((#:CLASS-NAME22897 NAME))
(EVAL `(DEFCLASS ,#:CLASS-NAME22897 NIL NIL))
(MAKE-INSTANCE #:CLASS-NAME22897))
CL-USER 22 > (myfunc 'baz42)
#<BAZ42 40202BBE73>
But then, there is no reason that it should be a macro!
A normal function is just fine...
(defun create-class-and-instance (name)
(eval `(defclass ,name () ()))
(make-instance name))
The defclass macro generally expands into a call to the actual implementation-dependent function that creates the class. If you can call that function instead, you can get rid of eval. This is a little more direct and keeps the current lexical environment.
If you load the closer-mop system, you can write your function as follows:
(defun make-instance-from-new-class (class-name)
(make-instance (closer-mop:ensure-class class-name)))
I have a list of the names of slots of a CLOS object:
(DEFCLASS TRIAL-DATA (STANDARD-OBJECT)
((A-DATUM :ACCESSOR A-DATUM :INITARG :A-DATUM :INITFORM NIL)
(BOTH-DATA :ACCESSOR BOTH-DATA :INITARG :BOTH-DATA :INITFORM 0)
(CUMULATIVE-DATA :ACCESSOR CUMULATIVE-DATA :INITARG :CUMULATIVE-DATA :INITFORM NIL)
(NAME :ACCESSOR NAME :INITARG :NAME :INITFORM VALUE)))
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
I can read the values of these slots:
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
(funcall (symbol-function (nth 0 slot-lst)) td))
==> NIL
But why can I not write new values to these slots? Shouldn't my class definition of trial-data have created an accessor function for each slot?
;; Should set the first slot, a-datum's, value to 42
(let* ((td (make-instance 'trial-data))
(slot-lst (mapcar #'slot-definition-name (class-slots (class-of td)))))
(setf (funcall (symbol-function (nth 0 slot-lst)) td) 42))
==>
;Compiler warnings for "/Users/frank/Documents/NRL/Error/Patrolbot/Patrol Construction Notes & Testing.lisp" :
; In an anonymous lambda form at position 123: Undefined function (SETF FUNCALL)
> Error: Undefined function (SETF FUNCALL) called with arguments (42 #<STANDARD-GENERIC-FUNCTION A-DATUM #x302001D1C5DF> #<TRIAL-DATA #x30200200D95D>) .
> While executing: #<Anonymous Function #x30200200EB7F>, in process Listener-2(5).
The accessor is called a-datum.
The reader:
CL-USER 9 > #'a-datum
#<STANDARD-GENERIC-FUNCTION A-DATUM 406000091C>
The writer:
CL-USER 10 > #'(setf a-datum)
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
If you want to call via funcall the writer, you need to call above function.
If you have a plain form (setf (a-datum foo) 'bar)) then this needs to be resolved at macro expansion time.
The error message says that #'(setf funcall) is undefined. Thus (setf (funcall ...) ...) does not exist.
How do you get the writer function in your case?
CL-USER 11 > (fdefinition '(setf a-datum))
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
CL-USER 12 > (let ((name 'a-datum)) (fdefinition `(setf ,name)))
#<STANDARD-GENERIC-FUNCTION (SETF A-DATUM) 422000958C>
Task for you: what are the correct arguments for above function?
Rainer Joswigs's answer addresses the issue of why you can't set with the code that you have now. However, it's also important to note that there's no reason that reader, writer, or accessor name has to be the same as the slot name, so if what you've actually got is the slot name, then you should use (setf slot-value) with it. E.g.,
(defclass foo ()
((bar :accessor getbar :initform 42)))
(defparameter *foo* (make-instance 'foo))
;; neither of these work
(setf (bar *foo*) 34)
(funcall #'(setf bar) 34 *foo*)
(slot-value *foo* 'bar)
;=> 42
(setf (slot-value *foo* 'bar) 36)
;=> 26
(slot-value *foo* 'bar)
;=> 36