[Openmcl-devel] need some help with "Unhandled exception"
Taoufik Dachraoui
dachraoui.taoufik at gmail.com
Sun Dec 29 06:41:18 PST 2013
sorry the macrolet is not necessary in the foo function
(defmacro defrule (name args &rest body)
(let ((foo (gensym))
(vars (loop for v in args until (eq v :locals) collect v))
(locals (cadr (member :locals args))))
`(progn
(ccl::%defun
(nfunction ,foo
(LAMBDA ,vars
(let ,(mapcar #'(lambda (x) `(,x (if (and (var? ,x)
(boundp ,x)) (symbol-value ,x) ,x)))
vars)
(declare (special , at vars))
,@(mapcar #'(lambda (x) `(if (var? ,x) (makunbound
',x))) ; unbound the local variable and not the passed one
vars)
(with-locals ,locals ; unbound locals and revert
back to exact state of locals before running body
, at body))))
'nil)
(defmacro ,name ,vars
(list ',foo
,@(mapcar #'(lambda (x) ``',,x) vars) ; quote arguments of
the function foo to avoid eval
)))))
Regards
Taoufik
On Sun, Dec 29, 2013 at 3:33 PM, Taoufik Dachraoui <
dachraoui.taoufik at gmail.com> wrote:
> Hi
>
> I amanged to define the macro defrule that do what I want but it was a
> difficult process.
> The issue is to manage the special variables ?x,?y,... that are used by the
> select patterns;
>
> if a svar is bound then the symbol value replaces the svar in the pattern
> otherwise the query
> will return all possible matches with the svar within the db.
>
> (defun var? (x)
> (and (symbolp x) (not (keywordp x)) (eq (char (symbol-name x) 0) #\?)))
>
> (defmacro with-locals (locals &rest body)
> (if (null locals)
> `(progn , at body)
> (let ((old-values (gensym)) (dummy (intern (symbol-name (gensym))
> :keyword)))
> `(let ((,old-values (mapcar #'(lambda (x) (if (boundp x)
> (symbol-value x) ,dummy))
> ',locals)))
> ,@(mapcar #'(lambda (x) `(makunbound ',x)) locals)
> (let ((r (progn , at body)))
> (mapcar #'(lambda (x y) (if (not (eq ,dummy y)) (setf
> (symbol-value x) y))) ',locals ,old-values)
> r)))))
>
> (defmacro defrule (name args &rest body)
> (let ((foo (gensym))
> (vars (loop for v in args until (eq v :locals) collect v))
> (locals (cadr (member :locals args))))
> `(progn
> (ccl::%defun
> (nfunction ,foo
> (LAMBDA ,vars
> (let ,(mapcar #'(lambda (x) `(,x (if (and (var? ,x)
> (boundp ,x)) (symbol-value ,x) ,x)))
> vars)
> (declare (special , at vars))
> ,@(mapcar #'(lambda (x) `(if (var? ,x)
> (makunbound ',x))) ; unbound the local variable and not the passed one
>
> vars)
> (with-locals ,locals ; unbound locals and revert
> back to exact state of locals before running body
>
> (macrolet ((,name ,vars ; within foo the macro
> name is redirected to call foo recursively
>
> (list ',foo ,@(mapcar #'(lambda (x) ``',,x) vars))))
> , at body)))))
> 'nil)
> (defmacro ,name ,vars
> (list ',foo
> ,@(mapcar #'(lambda (x) ``',,x) vars) ; quote arguments to
> function foo to avoid eval
>
> )))))
>
> (defrule ancestor (?x ?y :locals (?z))
> (union
> (select-loop (parent ?x ?y) collect `(ancestor ,?x ,?y))
> (select-loop (parent ?x ?z)
> append (loop for a in (ancestor ?z ?y) collect `(ancestor
> ,?x ,(third a)))
> )))
>
> Example:
>
> (assert-fact (parent b a))
> (assert-fact (parent c b))
> (assert-fact (parent d c))
> (assert-fact (parent e d))
>
> ? (ancestor ?x b)
> ((ANCESTOR C B) (ANCESTOR E B) (ANCESTOR D B))
> ? (ancestor ?x d)
> ((ANCESTOR E D))
> ? (ancestor c ?x)
> ((ANCESTOR C B) (ANCESTOR C A))
> ? (ancestor d ?x)
> ((ANCESTOR D C) (ANCESTOR D B) (ANCESTOR D A))
> ? (ancestor ?x ?y)
> ((ANCESTOR B A) (ANCESTOR C B) (ANCESTOR D C) (ANCESTOR E D) (ANCESTOR E
> C) (ANCESTOR E B) (ANCESTOR E A) (ANCESTOR D B) (ANCESTOR D A) (ANCESTOR C
> A))
>
>
> ;;; compare this to prolog
>
> ;;; (ancestor X Y) :- (parent X Y).
>
>
> ;;; (ancestor X Y) :- (parent X Z),(ancestor Z Y).
>
>
>
> I am planning do the same with another magic macro
> the objective is to be able to define a rule such this:
> (defrule ancestor (?x ?y) (or (parent ?x ?y) (and (parent ?x ?z)
> (ancestor ?z ?y))))
>
> where the disjunctions will be transformed to unions and the conjunctions
> to nested select-loops;
> I am not there yet, it is difficult because of the special variables that
> I have to manage I am wondering
> if lexicons/dlets of Ron Garret can help here?
>
> If there is a simpler solution to this I will be happy to hear from you
>
> Kind regards
> Taoufik
>
>
>
> On Sat, Dec 28, 2013 at 10:35 PM, Taoufik Dachraoui <
> dachraoui.taoufik at gmail.com> wrote:
>
>> Hi
>>
>> Thank you for the rapid reply
>>
>> the select accepts a pattern with special variables (?x, ?y, ...)
>>
>> The select when it founds a bound special variable ?x it will replace it
>> by its value in the pattern
>>
>> Example: with ?x unbound (select-loop (p ?x a) collect it) will return
>> all expressions in the db where the first and the third
>> elements are p and a respectively, but if ?x is bound to Z say, then the
>> select will return (p Z a) if it exists in the db
>>
>> I did this in order to embed queries like the following:
>>
>> (select-loop (p ?x a) append (select-loop (?x ?y) collect it) (the
>> second ?x will be bound to the value of ?x returned by the
>> first select (nested loops)
>>
>> I did not see the infinite loop I will check again and see if I can solve
>> this
>>
>> Thanks
>> Taoufik
>>
>>
>>
>> On Sat, Dec 28, 2013 at 10:06 PM, Ron Garret <ron at flownet.com> wrote:
>>
>>> You have an infinite loop in your macroexpansion:
>>>
>>> ? (macroexpand-all '(ancestor ?x a))
>>> > Error: Stack overflow on value stack.
>>>
>>> Also, I have no idea what this code is intended to do, but whatever it
>>> is this almost certainly isn’t helping:
>>>
>>> ? (pprint (macroexpand '(ancestor ?x a)))
>>>
>>> (LET ((?X '?X) (?Y 'A))
>>> (DECLARE (SPECIAL ?X ?Y))
>>> (IF (VAR? ?X) (MAKUNBOUND ?X))
>>> (IF (VAR? ?Y) (MAKUNBOUND ?Y))
>>> (UNION (SELECT-LOOP (P ?X ?Y) COLLECT IT)
>>> (SELECT-LOOP (P ?X ?Z) APPEND (ANCESTOR ?Z ?Y))))
>>>
>>> You are binding ?X to itself, and then immediately making it unbound
>>> again. That is almost certainly not what you want to do.
>>>
>>> rg
>>>
>>>
>>> On Dec 28, 2013, at 12:05 PM, Taoufik Dachraoui <
>>> dachraoui.taoufik at gmail.com> wrote:
>>>
>>> > Hi
>>> >
>>> > Could you please check this "Unhandled exception" and explain what is
>>> wrong
>>> > with my code
>>> >
>>> > (defun var? (x)
>>> > (and (symbolp x) (not (keywordp x)) (eq (char (symbol-name x) 0)
>>> #\?)))
>>> >
>>> > (defun vars-in (expr)
>>> > (if (atom expr)
>>> > (if (var? expr) (list expr))
>>> > (union
>>> > (vars-in (car expr))
>>> > (vars-in (cdr expr)))))
>>> >
>>> > (defmacro aif (test-form then-form &optional else-form)
>>> > `(let ((it ,test-form))
>>> > (if it ,then-form ,else-form)))
>>> >
>>> > (defun select! (pat) ; returns a list of bindings
>>> > (print pat)
>>> > '((it . (p b a)) (?x . 'b)))
>>> >
>>> > (defmacro select-loop (pat &rest keywords-and-forms)
>>> > (let ((bind (gensym))
>>> > (vars (cons 'it (vars-in pat))))
>>> > `(block select-loop
>>> > (aif (select! ',pat)
>>> > (progn
>>> > (let ((binds it) ,@(mapcar #'list vars))
>>> > (declare (special , at vars))
>>> > (loop for ,bind in binds
>>> > do (progn
>>> > (setf it (cdr (assoc 'it ,bind)))
>>> > ,@(mapcar #'(lambda (v) `(setf ,v (cdr (assoc
>>> ',v ,bind))))
>>> > vars))
>>> > , at keywords-and-forms)))))))
>>> >
>>> > (defmacro defrule (name args &rest body)
>>> > `(defmacro ,name ,args
>>> > (list 'let (list ,@(mapcar #'(lambda (x) `(list ',x `',,x)) args))
>>> > '(declare (special , at args))
>>> > ,@(mapcar #'(lambda (x) `'(if (var? ,x) (makunbound ,x))) args)
>>> > ,@(mapcar #'(lambda (x) `',x) body))))
>>> >
>>> > (defrule ancestor (?x ?y)
>>> > (union
>>> > (select-loop (p ?x ?y) collect it)
>>> > (select-loop (p ?x ?z)
>>> > append (ancestor ?z ?y))))
>>> >
>>> > ? (ancestor ?x a)
>>> >
>>> > Unhandled exception 10 at 0x28545, context->regs at #xb01641fc
>>> > Exception occurred while executing foreign code
>>> > at compact_dynamic_heap + 965
>>> > received signal 10; faulting address: 0xd360000
>>> > ? for help
>>> > [3422] Clozure CL kernel debugger: ?
>>> > (G) Set specified GPR to new value
>>> > (R) Show raw GPR/SPR register values
>>> > (L) Show Lisp values of tagged registers
>>> > (F) Show FPU registers
>>> > (S) Find and describe symbol matching specified name
>>> > (B) Show backtrace
>>> > (T) Show info about current thread
>>> > (M) Show memory areas
>>> > (X) Exit from this debugger, asserting that any exception was handled
>>> > (P) Propagate the exception to another handler (debugger or OS)
>>> > (K) Kill Clozure CL process
>>> > (V) Show Subversion revision information
>>> > (?) Show this help
>>> > [3422] Clozure CL kernel debugger: B
>>> > current thread: tcr = 0x2000f0, native thread ID = 0xbe03, interrupts
>>> enabled
>>> >
>>> >
>>> > Bogus frame 606b40
>>> > [3422] Clozure CL kernel debugger: L
>>> > [3422] Clozure CL kernel debugger:
>>> >
>>> >
>>> > Kind regards
>>> > Taoufik
>>> >
>>> > _______________________________________________
>>> > Openmcl-devel mailing list
>>> > Openmcl-devel at clozure.com
>>> > http://clozure.com/mailman/listinfo/openmcl-devel
>>>
>>>
>>
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20131229/036c375d/attachment.htm>
More information about the Openmcl-devel
mailing list