[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