[Openmcl-devel] need some help with "Unhandled exception"
Taoufik Dachraoui
dachraoui.taoufik at gmail.com
Sun Dec 29 06:33:39 PST 2013
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/8e201a28/attachment.htm>
More information about the Openmcl-devel
mailing list