1#!/usr/bin/env swipl
6
7:-style_check(-discontiguous). 8:-style_check(-singleton). 9:-use_module(library(wamcl_runtime)). 10
11/*
12;; #+BUILTIN Means to ignore since it should already be defined
13*/
14/*
15;; #+WAM-CL Means we want it
16*/
17/*
18;; #+LISP500 Means probably we dont want it
19*/
20/*
21;; #+ALT Alternative definition
22*/
23/*
24;; #+ABCL From ABCL
25*/
26/*
27;; #+SBCL From SBCL
28*/
29/*
30;; #+ECL From ECL
31*/
32/*
33;; #+SICL From SICL
34*/
35/*
36(in-package "SYSTEM")
37
38
39*/
40
41/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:262 **********************/
42:-lisp_compile_to_prolog(pkg_sys,['in-package','#:system'])
43/*
44% macroexpand:-[in_package,system2].
45*/
46/*
47% into:-[eval_when,[kw_compile_toplevel,kw_load_toplevel,kw_execute],[sys_select_package,'$ARRAY'([*],claz_base_character,"SYSTEM")]].
48*/
49:- do_when([kw_compile_toplevel, kw_load_toplevel, kw_execute],
50 f_sys_select_package('$ARRAY'([*], claz_base_character, "SYSTEM"),
51 _Ignored),
52 _Ignored).
53/*
54#-WAM-CL (defmacro put-sysprop (s p v) `(setf (get ,s ,p) ,v ))
55
56
57*/
58
59/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:294 **********************/
60:-lisp_compile_to_prolog(pkg_sys,'$COMMENT'([flag_removed,[-,':WAM-CL'],[defmacro,'put-sysprop',[s,p,v],['#BQ',[setf,[get,['#COMMA',s],['#COMMA',p]],['#COMMA',v]]]]]))
61/*
62(defclass pathname ()
63 ((host :accessor pathname-host
64 :initarg :host
65 :initform nil)
66 (device :accessor pathname-device
67 :initarg :device
68 :initform :unspecific)
69 (directory :accessor pathname-directory
70 :initarg :directory
71 :initform nil)
72 (name :accessor pathname-name
73 :initarg :name
74 :initform nil)
75 (type :accessor pathname-type
76 :initarg :type
77 :initform nil)
78 (version :accessor pathname-version
79 :initarg :version
80 :initform nil))
81 (:documentation "A physical pathname."))
82
83*/
84
85/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:363 **********************/
86:-lisp_compile_to_prolog(pkg_sys,[defclass,pathname,[],[[host,':accessor','pathname-host',':initarg',':host',':initform',[]],[device,':accessor','pathname-device',':initarg',':device',':initform',':unspecific'],[directory,':accessor','pathname-directory',':initarg',':directory',':initform',[]],[name,':accessor','pathname-name',':initarg',':name',':initform',[]],[type,':accessor','pathname-type',':initarg',':type',':initform',[]],[version,':accessor','pathname-version',':initarg',':version',':initform',[]]],[':documentation','$STRING'("A physical pathname.")]])
87:- sf_defclass(Sf_defclass_Param,
88
89 [ pathname,
90 [],
91
92 [
93 [ sys_host,
94 kw_accessor,
95 pathname_host,
96 kw_initarg,
97 kw_host,
98 kw_initform,
99 []
100 ],
101
102 [ sys_device,
103 kw_accessor,
104 pathname_device,
105 kw_initarg,
106 kw_device,
107 kw_initform,
108 kw_unspecific
109 ],
110
111 [ directory,
112 kw_accessor,
113 pathname_directory,
114 kw_initarg,
115 kw_directory,
116 kw_initform,
117 []
118 ],
119
120 [ sys_name,
121 kw_accessor,
122 pathname_name,
123 kw_initarg,
124 kw_name,
125 kw_initform,
126 []
127 ],
128
129 [ type,
130 kw_accessor,
131 pathname_type,
132 kw_initarg,
133 kw_type,
134 kw_initform,
135 []
136 ],
137
138 [ sys_version,
139 kw_accessor,
140 pathname_version,
141 kw_initarg,
142 kw_version,
143 kw_initform,
144 []
145 ]
146 ],
147
148 [ kw_documentation,
149 '$ARRAY'([*], claz_base_character, "A physical pathname.")
150 ]
151 ],
152 _Ignored).
153/*
154(defmethod print-object ((self pathname) stream)
155 (format stream ""(defmethod print-object ((self pathname) stream)\r\n (format stream \"~:[~;#P\\\"~]~A~0@*~:[~;\\\"~]\" *print-escape* (namestring self))\r\n self)\r\n\r\n\r\n".
156*/
157
158/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:1055 **********************/
159:-lisp_compile_to_prolog(pkg_sys,[defmethod,'print-object',[[self,pathname],stream],[format,stream,'$STRING'("~:[~;#P\"~]~A~0@*~:[~;\"~]"),'*print-escape*',[namestring,self]],self])
160 defmethod(print_object,
161 [[sys_self, pathname], stream],
162
163 [
164 [ format,
165 stream,
166 '$ARRAY'([*],
167 claz_base_character,
168 "~:[~;#P\"~]~A~0@*~:[~;\"~]"),
169 xx_print_escape_xx,
170 [namestring, sys_self]
171 ],
172 sys_self
173 ]).
174
175/*
176(defmacro defun=sourceinfo (name ll &rest body)
177 "Used to show what was already compiled"
178 `(put-sysprop ',name 'defun=sourceinfo `(defun ,',name ,',ll ,',@body)))
179
180*/
181
182/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:1199 **********************/
183:-lisp_compile_to_prolog(pkg_sys,[defmacro,'defun=sourceinfo',[name,ll,'&rest',body],'$STRING'("Used to show what was already compiled"),['#BQ',['put-sysprop',[quote,['#COMMA',name]],[quote,'defun=sourceinfo'],['#BQ',[defun,['#COMMA',[quote,['#COMMA',name]]],['#COMMA',[quote,['#COMMA',ll]]],['#COMMA',[quote,['#BQ-COMMA-ELIPSE',body]]]]]]]])
184/*
185:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
186 sys_defun_c61_sourceinfo,
187 kw_macro,
188 mf_sys_defun_c61_sourceinfo)).
189*/
190/*
191:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
192 sys_defun_c61_sourceinfo,
193 kw_special,
194 sf_sys_defun_c61_sourceinfo)).
195*/
196doc: doc_string(sys_defun_c61_sourceinfo,
197 _7912,
198 function,
199 "Used to show what was already compiled").
200
201wl:lambda_def(defmacro, sys_defun_c61_sourceinfo, mf_sys_defun_c61_sourceinfo, [sys_name, sys_ll, c38_rest, sys_body], [['#BQ', [sys_put_sysprop, [quote, ['#COMMA', sys_name]], [quote, sys_defun_c61_sourceinfo], ['#BQ', [defun, ['#COMMA', [quote, ['#COMMA', sys_name]]], ['#COMMA', [quote, ['#COMMA', sys_ll]]], ['#COMMA', [quote, ['#BQ-COMMA-ELIPSE', sys_body]]]]]]]]).
202wl:arglist_info(sys_defun_c61_sourceinfo, mf_sys_defun_c61_sourceinfo, [sys_name, sys_ll, c38_rest, sys_body], arginfo{all:[sys_name, sys_ll], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_name, sys_ll, sys_body], opt:0, req:[sys_name, sys_ll], rest:[sys_body], sublists:0, whole:0}).
203wl: init_args(2, mf_sys_defun_c61_sourceinfo).
204
209sf_sys_defun_c61_sourceinfo(MacroEnv, Name_In, Ll_In, RestNKeys, FResult) :-
210 mf_sys_defun_c61_sourceinfo(
211 [ sys_defun_c61_sourceinfo,
212 Name_In,
213 Ll_In
214 | RestNKeys
215 ],
216 MacroEnv,
217 MFResult),
218 f_sys_env_eval(MacroEnv, MFResult, FResult).
223mf_sys_defun_c61_sourceinfo([sys_defun_c61_sourceinfo, Name_In, Ll_In|RestNKeys], MacroEnv, MFResult) :-
224 nop(defmacro),
225 GEnv=[bv(sys_name, Name_In), bv(sys_ll, Ll_In), bv(sys_body, RestNKeys)],
226 catch(( ( ( get_var(GEnv, sys_body, Body_Get),
227 get_var(GEnv, sys_ll, Ll_Get)
228 ),
229 get_var(GEnv, sys_name, Name_Get8)
230 ),
231 [sys_put_sysprop, [quote, Name_Get8], [quote, sys_defun_c61_sourceinfo], ['#BQ', [defun, ['#COMMA', [quote, Name_Get8]], ['#COMMA', [quote, Ll_Get]], ['#COMMA', [quote|Body_Get]]]]]=MFResult
232 ),
233 block_exit(sys_defun_c61_sourceinfo, MFResult),
234 true).
235:- set_opv(mf_sys_defun_c61_sourceinfo, type_of, sys_macro),
236 set_opv(sys_defun_c61_sourceinfo,
237 symbol_function,
238 mf_sys_defun_c61_sourceinfo),
239 DefMacroResult=sys_defun_c61_sourceinfo. 240/*
241:- side_effect(assert_lsp(sys_defun_c61_sourceinfo,
242 doc_string(sys_defun_c61_sourceinfo,
243 _7910,
244 function,
245 "Used to show what was already compiled"))).
246*/
247/*
248:- side_effect(assert_lsp(sys_defun_c61_sourceinfo,
249 lambda_def(defmacro,
250 sys_defun_c61_sourceinfo,
251 mf_sys_defun_c61_sourceinfo,
252 [sys_name, sys_ll, c38_rest, sys_body],
253
254 [
255 [ '#BQ',
256
257 [ sys_put_sysprop,
258 [quote, ['#COMMA', sys_name]],
259 [quote, sys_defun_c61_sourceinfo],
260
261 [ '#BQ',
262
263 [ defun,
264
265 [ '#COMMA',
266 [quote, ['#COMMA', sys_name]]
267 ],
268
269 [ '#COMMA',
270 [quote, ['#COMMA', sys_ll]]
271 ],
272
273 [ '#COMMA',
274
275 [ quote,
276
277 [ '#BQ-COMMA-ELIPSE',
278 sys_body
279 ]
280 ]
281 ]
282 ]
283 ]
284 ]
285 ]
286 ]))).
287*/
288/*
289:- side_effect(assert_lsp(sys_defun_c61_sourceinfo,
290 arglist_info(sys_defun_c61_sourceinfo,
291 mf_sys_defun_c61_sourceinfo,
292 [sys_name, sys_ll, c38_rest, sys_body],
293 arginfo{ all:[sys_name, sys_ll],
294 allow_other_keys:0,
295 aux:0,
296 body:0,
297 complex:[rest],
298 env:0,
299 key:0,
300 names:
301 [ sys_name,
302 sys_ll,
303 sys_body
304 ],
305 opt:0,
306 req:[sys_name, sys_ll],
307 rest:[sys_body],
308 sublists:0,
309 whole:0
310 }))).
311*/
312/*
313:- side_effect(assert_lsp(sys_defun_c61_sourceinfo,
314 init_args(2, mf_sys_defun_c61_sourceinfo))).
315*/
316/*
317(defmacro defmacro=sourceinfo (name ll &rest body)
318 "Used to show what was already compiled"
319 `(put-sysprop ',name 'defmacro=sourceinfo '(defmacro ,name ,ll ,@body)))
320
321
322*/
323
324/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:1371 **********************/
325:-lisp_compile_to_prolog(pkg_sys,[defmacro,'defmacro=sourceinfo',[name,ll,'&rest',body],'$STRING'("Used to show what was already compiled"),['#BQ',['put-sysprop',[quote,['#COMMA',name]],[quote,'defmacro=sourceinfo'],[quote,[defmacro,['#COMMA',name],['#COMMA',ll],['#BQ-COMMA-ELIPSE',body]]]]]])
326/*
327:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
328 sys_defmacro_c61_sourceinfo,
329 kw_macro,
330 mf_sys_defmacro_c61_sourceinfo)).
331*/
332/*
333:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
334 sys_defmacro_c61_sourceinfo,
335 kw_special,
336 sf_sys_defmacro_c61_sourceinfo)).
337*/
338doc: doc_string(sys_defmacro_c61_sourceinfo,
339 _7626,
340 function,
341 "Used to show what was already compiled").
342
343wl:lambda_def(defmacro, sys_defmacro_c61_sourceinfo, mf_sys_defmacro_c61_sourceinfo, [sys_name, sys_ll, c38_rest, sys_body], [['#BQ', [sys_put_sysprop, [quote, ['#COMMA', sys_name]], [quote, sys_defmacro_c61_sourceinfo], [quote, [defmacro, ['#COMMA', sys_name], ['#COMMA', sys_ll], ['#BQ-COMMA-ELIPSE', sys_body]]]]]]).
344wl:arglist_info(sys_defmacro_c61_sourceinfo, mf_sys_defmacro_c61_sourceinfo, [sys_name, sys_ll, c38_rest, sys_body], arginfo{all:[sys_name, sys_ll], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_name, sys_ll, sys_body], opt:0, req:[sys_name, sys_ll], rest:[sys_body], sublists:0, whole:0}).
345wl: init_args(2, mf_sys_defmacro_c61_sourceinfo).
346
351sf_sys_defmacro_c61_sourceinfo(MacroEnv, Name_In, Ll_In, RestNKeys, FResult) :-
352 mf_sys_defmacro_c61_sourceinfo(
353 [ sys_defmacro_c61_sourceinfo,
354 Name_In,
355 Ll_In
356 | RestNKeys
357 ],
358 MacroEnv,
359 MFResult),
360 f_sys_env_eval(MacroEnv, MFResult, FResult).
365mf_sys_defmacro_c61_sourceinfo([sys_defmacro_c61_sourceinfo, Name_In, Ll_In|RestNKeys], MacroEnv, MFResult) :-
366 nop(defmacro),
367 GEnv=[bv(sys_name, Name_In), bv(sys_ll, Ll_In), bv(sys_body, RestNKeys)],
368 catch(( ( ( get_var(GEnv, sys_body, Body_Get),
369 get_var(GEnv, sys_ll, Ll_Get)
370 ),
371 get_var(GEnv, sys_name, Name_Get8)
372 ),
373 [sys_put_sysprop, [quote, Name_Get8], [quote, sys_defmacro_c61_sourceinfo], [quote, [defmacro, Name_Get8, Ll_Get|Body_Get]]]=MFResult
374 ),
375 block_exit(sys_defmacro_c61_sourceinfo, MFResult),
376 true).
377:- set_opv(mf_sys_defmacro_c61_sourceinfo, type_of, sys_macro),
378 set_opv(sys_defmacro_c61_sourceinfo,
379 symbol_function,
380 mf_sys_defmacro_c61_sourceinfo),
381 DefMacroResult=sys_defmacro_c61_sourceinfo. 382/*
383:- side_effect(assert_lsp(sys_defmacro_c61_sourceinfo,
384 doc_string(sys_defmacro_c61_sourceinfo,
385 _7626,
386 function,
387 "Used to show what was already compiled"))).
388*/
389/*
390:- side_effect(assert_lsp(sys_defmacro_c61_sourceinfo,
391 lambda_def(defmacro,
392 sys_defmacro_c61_sourceinfo,
393 mf_sys_defmacro_c61_sourceinfo,
394 [sys_name, sys_ll, c38_rest, sys_body],
395
396 [
397 [ '#BQ',
398
399 [ sys_put_sysprop,
400 [quote, ['#COMMA', sys_name]],
401 [quote, sys_defmacro_c61_sourceinfo],
402
403 [ quote,
404
405 [ defmacro,
406 ['#COMMA', sys_name],
407 ['#COMMA', sys_ll],
408 ['#BQ-COMMA-ELIPSE', sys_body]
409 ]
410 ]
411 ]
412 ]
413 ]))).
414*/
415/*
416:- side_effect(assert_lsp(sys_defmacro_c61_sourceinfo,
417 arglist_info(sys_defmacro_c61_sourceinfo,
418 mf_sys_defmacro_c61_sourceinfo,
419 [sys_name, sys_ll, c38_rest, sys_body],
420 arginfo{ all:[sys_name, sys_ll],
421 allow_other_keys:0,
422 aux:0,
423 body:0,
424 complex:[rest],
425 env:0,
426 key:0,
427 names:
428 [ sys_name,
429 sys_ll,
430 sys_body
431 ],
432 opt:0,
433 req:[sys_name, sys_ll],
434 rest:[sys_body],
435 sublists:0,
436 whole:0
437 }))).
438*/
439/*
440:- side_effect(assert_lsp(sys_defmacro_c61_sourceinfo,
441 init_args(2, mf_sys_defmacro_c61_sourceinfo))).
442*/
443/*
444(defmacro assert (test-form &optional places string &rest args)
445 (declare (dynamic-extent args))
446 `(do nil (,test-form nil)
447 (multiple-value-setq
448 ,places
449 (apply 'assert-places ',places (list ,@places)
450 ,@(if string `(,string (list ,@args)) `("The assertion "(defmacro assert (test-form &optional places string &rest args)\r\n (declare (dynamic-extent args))\r\n `(do nil (,test-form nil)\r\n (multiple-value-setq\r\n\t ,places\r\n (apply 'assert-places ',places (list ,@places)\r\n\t ,@(if string `(,string (list ,@args)) `(\"The assertion ~:@(~S~) failed.\" ',test-form nil))))))\r\n\r\n\r\n".
451*/
452
453/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:1549 **********************/
454:-lisp_compile_to_prolog(pkg_sys,[defmacro,assert,['test-form','&optional',places,string,'&rest',args],[declare,['dynamic-extent',args]],['#BQ',[do,[],[['#COMMA','test-form'],[]],['multiple-value-setq',['#COMMA',places],[apply,[quote,'assert-places'],[quote,['#COMMA',places]],[list,['#BQ-COMMA-ELIPSE',places]],['#BQ-COMMA-ELIPSE',[if,string,['#BQ',[['#COMMA',string],[list,['#BQ-COMMA-ELIPSE',args]]]],['#BQ',['$STRING'("The assertion ~:@(~S~) failed."),[quote,['#COMMA','test-form']],[]]]]]]]]]])
455/*
456:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
457 assert,
458 kw_special,
459 sf_assert)).
460*/
461wl:lambda_def(defmacro, assert, mf_assert, [sys_test_form, c38_optional, sys_places, string, c38_rest, sys_args], [[declare, [dynamic_extent, sys_args]], ['#BQ', [do, [], [['#COMMA', sys_test_form], []], [multiple_value_setq, ['#COMMA', sys_places], [apply, [quote, sys_assert_places], [quote, ['#COMMA', sys_places]], [list, ['#BQ-COMMA-ELIPSE', sys_places]], ['#BQ-COMMA-ELIPSE', [if, string, ['#BQ', [['#COMMA', string], [list, ['#BQ-COMMA-ELIPSE', sys_args]]]], ['#BQ', ['$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [quote, ['#COMMA', sys_test_form]], []]]]]]]]]]).
462wl:arglist_info(assert, mf_assert, [sys_test_form, c38_optional, sys_places, string, c38_rest, sys_args], arginfo{all:[sys_test_form, sys_places, string], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_test_form, sys_places, string, sys_args], opt:[sys_places, string], req:[sys_test_form], rest:[sys_args], sublists:0, whole:0}).
463wl: init_args(1, mf_assert).
464
469sf_assert(MacroEnv, Test_form_In, Optionals, FResult) :-
470 mf_assert([assert, Test_form_In|Optionals], MacroEnv, MFResult),
471 f_sys_env_eval(MacroEnv, MFResult, FResult).
476mf_assert([assert, Test_form_In|Optionals], MacroEnv, MFResult) :-
477 nop(defmacro),
478 GEnv=[bv(sys_test_form, Test_form_In), bv(sys_places, Places_In), bv(string, String_In), bv(sys_args, Optionals)],
479 opt_var(MacroEnv, sys_places, Places_In, true, [], 1, Optionals),
480 opt_var(MacroEnv, string, String_In, true, [], 2, Optionals),
481 catch(( ( sf_declare(GEnv, [dynamic_extent, sys_args], Sf_declare_Ret),
482 get_var(GEnv, sys_places, Places_Get),
483 ( get_var(GEnv, string, IFTEST),
484 get_var(GEnv, sys_test_form, Test_form_Get)
485 ),
486 get_var(GEnv, sys_places, Places_Get11),
487 ( IFTEST\==[]
488 -> get_var(GEnv, string, String_Get16),
489 get_var(GEnv, sys_args, Args_Get),
490 CDR=[String_Get16, [list|Args_Get]]
491 ; get_var(GEnv, sys_test_form, Test_form_Get18),
492 CDR=['$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [quote, Test_form_Get18], []]
493 )
494 ),
495 [do, [], [Test_form_Get, []], [multiple_value_setq, Places_Get, [apply, [quote, sys_assert_places], [quote, Places_Get11], [list|Places_Get11]|CDR]]]=MFResult
496 ),
497 block_exit(assert, MFResult),
498 true).
499:- set_opv(mf_assert, type_of, sys_macro),
500 set_opv(assert, symbol_function, mf_assert),
501 DefMacroResult=assert. 502/*
503:- side_effect(assert_lsp(assert,
504 lambda_def(defmacro,
505 assert,
506 mf_assert,
507
508 [ sys_test_form,
509 c38_optional,
510 sys_places,
511 string,
512 c38_rest,
513 sys_args
514 ],
515
516 [ [declare, [dynamic_extent, sys_args]],
517
518 [ '#BQ',
519
520 [ do,
521 [],
522 [['#COMMA', sys_test_form], []],
523
524 [ multiple_value_setq,
525 ['#COMMA', sys_places],
526
527 [ apply,
528 [quote, sys_assert_places],
529 [quote, ['#COMMA', sys_places]],
530
531 [ list,
532
533 [ '#BQ-COMMA-ELIPSE',
534 sys_places
535 ]
536 ],
537
538 [ '#BQ-COMMA-ELIPSE',
539
540 [ if,
541 string,
542
543 [ '#BQ',
544
545 [ ['#COMMA', string],
546
547 [ list,
548
549 [ '#BQ-COMMA-ELIPSE',
550 sys_args
551 ]
552 ]
553 ]
554 ],
555
556 [ '#BQ',
557
558 [ '$ARRAY'([*],
559 claz_base_character,
560 "The assertion ~:@(~S~) failed."),
561
562 [ quote,
563
564 [ '#COMMA',
565 sys_test_form
566 ]
567 ],
568 []
569 ]
570 ]
571 ]
572 ]
573 ]
574 ]
575 ]
576 ]
577 ]))).
578*/
579/*
580:- side_effect(assert_lsp(assert,
581 arglist_info(assert,
582 mf_assert,
583
584 [ sys_test_form,
585 c38_optional,
586 sys_places,
587 string,
588 c38_rest,
589 sys_args
590 ],
591 arginfo{ all:
592 [ sys_test_form,
593 sys_places,
594 string
595 ],
596 allow_other_keys:0,
597 aux:0,
598 body:0,
599 complex:[rest],
600 env:0,
601 key:0,
602 names:
603 [ sys_test_form,
604 sys_places,
605 string,
606 sys_args
607 ],
608 opt:[sys_places, string],
609 req:[sys_test_form],
610 rest:[sys_args],
611 sublists:0,
612 whole:0
613 }))).
614*/
615/*
616:- side_effect(assert_lsp(assert, init_args(1, mf_assert))).
617*/
618/*
619(defmacro eval-when-tl ((&rest when) &body body) (if (or (member 'eval when) (member ':execute when)) `(progn ,@body) nil))
620
621*/
622
623/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:1878 **********************/
624:-lisp_compile_to_prolog(pkg_sys,[defmacro,'eval-when-tl',[['&rest',when],'&body',body],[if,[or,[member,[quote,eval],when],[member,[quote,':execute'],when]],['#BQ',[progn,['#BQ-COMMA-ELIPSE',body]]],[]]])
625/*
626:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
627 sys_eval_when_tl,
628 kw_macro,
629 mf_sys_eval_when_tl)).
630*/
631/*
632:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
633 sys_eval_when_tl,
634 kw_special,
635 sf_sys_eval_when_tl)).
636*/
637wl:lambda_def(defmacro, sys_eval_when_tl, mf_sys_eval_when_tl, [[c38_rest, when], c38_body, sys_body], [[if, [or, [member, [quote, eval], when], [member, [quote, kw_execute], when]], ['#BQ', [progn, ['#BQ-COMMA-ELIPSE', sys_body]]], []]]).
638wl:arglist_info(sys_eval_when_tl, mf_sys_eval_when_tl, [[c38_rest, when], c38_body, sys_body], arginfo{all:0, allow_other_keys:0, aux:0, body:[sys_body], complex:[body], env:0, key:0, names:[sys_body, when], opt:0, req:0, rest:[sys_body], sublists:0, whole:0}).
639wl: init_args(1, mf_sys_eval_when_tl).
640
645sf_sys_eval_when_tl(SubEnv, When_In, RestNKeys, FResult) :-
646 mf_sys_eval_when_tl([sys_eval_when_tl, When_In|RestNKeys],
647 SubEnv,
648 MFResult),
649 f_sys_env_eval(SubEnv, MFResult, FResult).
654mf_sys_eval_when_tl([sys_eval_when_tl, When_In|RestNKeys], SubEnv, MFResult) :-
655 nop(defmacro),
656 GEnv=[bv(sys_body, Body_In), bv(when, When_In)],
657 as_body(sys_body, Body_In, RestNKeys),
658 catch(( ( ( get_var(GEnv, when, When_Get),
659 f_member(eval, When_Get, [], FORM1_Res),
660 FORM1_Res\==[],
661 IFTEST=FORM1_Res
662 -> true
663 ; get_var(GEnv, when, When_Get10),
664 f_member(kw_execute, When_Get10, [], Member_Ret),
665 IFTEST=Member_Ret
666 ),
667 ( IFTEST\==[]
668 -> get_var(GEnv, sys_body, Body_Get),
669 _7212=[progn|Body_Get]
670 ; _7212=[]
671 )
672 ),
673 _7212=MFResult
674 ),
675 block_exit(sys_eval_when_tl, MFResult),
676 true).
677:- set_opv(mf_sys_eval_when_tl, type_of, sys_macro),
678 set_opv(sys_eval_when_tl, symbol_function, mf_sys_eval_when_tl),
679 DefMacroResult=sys_eval_when_tl. 680/*
681:- side_effect(assert_lsp(sys_eval_when_tl,
682 lambda_def(defmacro,
683 sys_eval_when_tl,
684 mf_sys_eval_when_tl,
685 [[c38_rest, when], c38_body, sys_body],
686
687 [
688 [ if,
689
690 [ or,
691 [member, [quote, eval], when],
692 [member, [quote, kw_execute], when]
693 ],
694
695 [ '#BQ',
696
697 [ progn,
698 ['#BQ-COMMA-ELIPSE', sys_body]
699 ]
700 ],
701 []
702 ]
703 ]))).
704*/
705/*
706:- side_effect(assert_lsp(sys_eval_when_tl,
707 arglist_info(sys_eval_when_tl,
708 mf_sys_eval_when_tl,
709 [[c38_rest, when], c38_body, sys_body],
710 arginfo{ all:0,
711 allow_other_keys:0,
712 aux:0,
713 body:[sys_body],
714 complex:[body],
715 env:0,
716 key:0,
717 names:[sys_body, when],
718 opt:0,
719 req:0,
720 rest:[sys_body],
721 sublists:0,
722 whole:0
723 }))).
724*/
725/*
726:- side_effect(assert_lsp(sys_eval_when_tl, init_args(1, mf_sys_eval_when_tl))).
727*/
728/*
729(defun list* (arg &rest others)
730 "Return a list of the arguments with last cons a dotted pair"
731 (cond ((null others) arg)
732 ((null (cdr others)) (cons arg (car others)))
733 (t (do ((x others (cdr x)))
734 ((null (cddr x)) (rplacd x (cadr x))))
735 (cons arg others))))
736
737
738*/
739
740/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:2006 **********************/
741:-lisp_compile_to_prolog(pkg_sys,[defun,'list*',[arg,'&rest',others],'$STRING'("Return a list of the arguments with last cons a dotted pair"),[cond,[[null,others],arg],[[null,[cdr,others]],[cons,arg,[car,others]]],[t,[do,[[x,others,[cdr,x]]],[[null,[cddr,x]],[rplacd,x,[cadr,x]]]],[cons,arg,others]]]])
742doc: doc_string(list_xx,
743 _8328,
744 function,
745 "Return a list of the arguments with last cons a dotted pair").
746
747wl:lambda_def(defun, list_xx, f_list_xx, [sys_arg, c38_rest, sys_others], [[cond, [[null, sys_others], sys_arg], [[null, [cdr, sys_others]], [cons, sys_arg, [car, sys_others]]], [t, [do, [[sys_x, sys_others, [cdr, sys_x]]], [[null, [cddr, sys_x]], [rplacd, sys_x, [cadr, sys_x]]]], [cons, sys_arg, sys_others]]]]).
748wl:arglist_info(list_xx, f_list_xx, [sys_arg, c38_rest, sys_others], arginfo{all:[sys_arg], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_arg, sys_others], opt:0, req:[sys_arg], rest:[sys_others], sublists:0, whole:0}).
749wl: init_args(1, f_list_xx).
750
755f_list_xx(Arg_In, RestNKeys, FnResult) :-
756 GEnv=[bv(sys_arg, Arg_In), bv(sys_others, RestNKeys)],
757 catch(( ( get_var(GEnv, sys_others, IFTEST),
758 ( IFTEST==[]
759 -> get_var(GEnv, sys_arg, Arg_Get),
760 _8408=Arg_Get
761 ; get_var(GEnv, sys_others, Others_Get12),
762 f_cdr(Others_Get12, IFTEST10),
763 ( IFTEST10==[]
764 -> get_var(GEnv, sys_arg, Arg_Get13),
765 get_var(GEnv, sys_others, Others_Get14),
766 f_car(Others_Get14, Car_Ret),
767 TrueResult52=[Arg_Get13|Car_Ret],
768 ElseResult55=TrueResult52
769 ; get_var(GEnv, sys_others, Others_Get18),
770 AEnv=[bv(sys_x, Others_Get18)|GEnv],
771 catch(( call_addr_block(AEnv,
772 (push_label(do_label_1), get_var(AEnv, sys_x, X_Get38), f_cddr(X_Get38, IFTEST36), (IFTEST36==[]->get_var(AEnv, sys_x, X_Get41), f_cadr(X_Get41, Cadr_Ret), f_rplacd(X_Get41, Cadr_Ret, RetResult39), throw(block_exit([], RetResult39)), _TBResult=ThrowResult40;get_var(AEnv, sys_x, X_Get45), f_cdr(X_Get45, X), set_var(AEnv, sys_x, X), goto(do_label_1, AEnv), _TBResult=_GORES46)),
773
774 [ addr(addr_tagbody_1_do_label_1,
775 do_label_1,
776 '$unused',
777 AEnv,
778 (get_var(AEnv, sys_x, Cddr_Param), f_cddr(Cddr_Param, IFTEST21), (IFTEST21==[]->get_var(AEnv, sys_x, X_Get26), f_cadr(X_Get26, Cadr_Ret63), f_rplacd(X_Get26, Cadr_Ret63, Rplacd_Ret), throw(block_exit([], Rplacd_Ret)), _9396=ThrowResult;get_var(AEnv, sys_x, X_Get30), f_cdr(X_Get30, Cdr_Ret), set_var(AEnv, sys_x, Cdr_Ret), goto(do_label_1, AEnv), _9396=_GORES)))
779 ]),
780 []=LetResult
781 ),
782 block_exit([], LetResult),
783 true),
784 get_var(GEnv, sys_arg, Arg_Get50),
785 get_var(GEnv, sys_others, Others_Get51),
786 ElseResult53=[Arg_Get50|Others_Get51],
787 ElseResult55=ElseResult53
788 ),
789 _8408=ElseResult55
790 )
791 ),
792 _8408=FnResult
793 ),
794 block_exit(list_xx, FnResult),
795 true).
796:- set_opv(list_xx, symbol_function, f_list_xx),
797 DefunResult=list_xx. 798/*
799:- side_effect(assert_lsp(list_xx,
800 doc_string(list_xx,
801 _8328,
802 function,
803 "Return a list of the arguments with last cons a dotted pair"))).
804*/
805/*
806:- side_effect(assert_lsp(list_xx,
807 lambda_def(defun,
808 list_xx,
809 f_list_xx,
810 [sys_arg, c38_rest, sys_others],
811
812 [
813 [ cond,
814 [[null, sys_others], sys_arg],
815
816 [ [null, [cdr, sys_others]],
817 [cons, sys_arg, [car, sys_others]]
818 ],
819
820 [ t,
821
822 [ do,
823 [[sys_x, sys_others, [cdr, sys_x]]],
824
825 [ [null, [cddr, sys_x]],
826 [rplacd, sys_x, [cadr, sys_x]]
827 ]
828 ],
829 [cons, sys_arg, sys_others]
830 ]
831 ]
832 ]))).
833*/
834/*
835:- side_effect(assert_lsp(list_xx,
836 arglist_info(list_xx,
837 f_list_xx,
838 [sys_arg, c38_rest, sys_others],
839 arginfo{ all:[sys_arg],
840 allow_other_keys:0,
841 aux:0,
842 body:0,
843 complex:[rest],
844 env:0,
845 key:0,
846 names:[sys_arg, sys_others],
847 opt:0,
848 req:[sys_arg],
849 rest:[sys_others],
850 sublists:0,
851 whole:0
852 }))).
853*/
854/*
855:- side_effect(assert_lsp(list_xx, init_args(1, f_list_xx))).
856*/
857/*
858(defmacro psetq (&environment env &rest args)
859 (do ((l args (cddr l))
860 (forms nil)
861 (bindings nil))
862 ((endp l) (list* 'let* (reverse bindings) (reverse (cons nil forms))))
863 (if (and (symbolp (car l))
864 (eq (car l) (macroexpand-1 (car l) env)))
865 (let ((sym (gensym)))
866 (push (list sym (cadr l)) bindings)
867 (push (list 'setq (car l) sym) forms))
868 (multiple-value-bind
869 (dummies vals newval setter getter)
870 (get-setf-expansion (macroexpand-1 (car l) env) env)
871 (declare (ignore getter))
872 (do ((d dummies (cdr d))
873 (v vals (cdr v)))
874 ((null d))
875 (push (list (car d) (car v)) bindings))
876 (push (list (car newval) (cadr l)) bindings)
877 (push setter forms)))))
878
879
880*/
881
882/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:2289 **********************/
883:-lisp_compile_to_prolog(pkg_sys,[defmacro,psetq,['&environment',env,'&rest',args],[do,[[l,args,[cddr,l]],[forms,[]],[bindings,[]]],[[endp,l],['list*',[quote,'let*'],[reverse,bindings],[reverse,[cons,[],forms]]]],[if,[and,[symbolp,[car,l]],[eq,[car,l],['macroexpand-1',[car,l],env]]],[let,[[sym,[gensym]]],[push,[list,sym,[cadr,l]],bindings],[push,[list,[quote,setq],[car,l],sym],forms]],['multiple-value-bind',[dummies,vals,newval,setter,getter],['get-setf-expansion',['macroexpand-1',[car,l],env],env],[declare,[ignore,getter]],[do,[[d,dummies,[cdr,d]],[v,vals,[cdr,v]]],[[null,d]],[push,[list,[car,d],[car,v]],bindings]],[push,[list,[car,newval],[cadr,l]],bindings],[push,setter,forms]]]]])
884/*
885:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
886 psetq,
887 kw_special,
888 sf_psetq)).
889*/
890wl:lambda_def(defmacro, psetq, mf_psetq, [c38_environment, sys_env, c38_rest, sys_args], [[do, [[sys_l, sys_args, [cddr, sys_l]], [sys_forms, []], [sys_bindings, []]], [[endp, sys_l], [list_xx, [quote, let_xx], [reverse, sys_bindings], [reverse, [cons, [], sys_forms]]]], [if, [and, [symbolp, [car, sys_l]], [eq, [car, sys_l], [macroexpand_1, [car, sys_l], sys_env]]], [let, [[sys_sym, [gensym]]], [push, [list, sys_sym, [cadr, sys_l]], sys_bindings], [push, [list, [quote, setq], [car, sys_l], sys_sym], sys_forms]], [multiple_value_bind, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter], [get_setf_expansion, [macroexpand_1, [car, sys_l], sys_env], sys_env], [declare, [ignore, sys_getter]], [do, [[sys_d, sys_dummies, [cdr, sys_d]], [sys_v, sys_vals, [cdr, sys_v]]], [[null, sys_d]], [push, [list, [car, sys_d], [car, sys_v]], sys_bindings]], [push, [list, [car, sys_newval], [cadr, sys_l]], sys_bindings], [push, sys_setter, sys_forms]]]]]).
891wl:arglist_info(psetq, mf_psetq, [c38_environment, sys_env, c38_rest, sys_args], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:[environment, rest], env:[sys_env], key:0, names:[sys_env, sys_args], opt:0, req:0, rest:[sys_args], sublists:0, whole:0}).
892wl: init_args(0, mf_psetq).
893
898sf_psetq(Env_In, RestNKeys, FResult) :-
899 mf_psetq([psetq|RestNKeys], Env_In, MFResult),
900 f_sys_env_eval(Env_In, MFResult, FResult).
905mf_psetq([psetq|RestNKeys], Env_In, MFResult) :-
906 nop(defmacro),
907 GEnv=[bv(sys_env, Env_In), bv(sys_args, RestNKeys)],
908 catch(( ( get_var(GEnv, sys_args, Args_Get),
909 AEnv=[bv(sys_l, Args_Get), bv(sys_forms, []), bv(sys_bindings, [])|GEnv],
910 catch(( call_addr_block(AEnv,
911 (push_label(do_label_2), get_var(AEnv, sys_l, L_Get84), (s3q:is_endp(L_Get84)->get_var(AEnv, sys_bindings, Bindings_Get89), f_reverse(Bindings_Get89, Reverse_Ret), get_var(AEnv, sys_forms, Forms_Get90), Reverse_Param=[[]|Forms_Get90], f_reverse(Reverse_Param, Reverse_Ret171), f_list_xx(let_xx, [Reverse_Ret, Reverse_Ret171], RetResult87), throw(block_exit([], RetResult87)), _TBResult=ThrowResult88;get_var(AEnv, sys_l, L_Get95), f_car(L_Get95, PredArgResult97), (is_symbolp(PredArgResult97)->get_var(AEnv, sys_l, L_Get98), f_car(L_Get98, Eq_Param), get_var(AEnv, sys_l, L_Get100), f_car(L_Get100, Car_Ret), get_var(AEnv, sys_env, Env_Get99), f_macroexpand_1([Car_Ret, Env_Get99], Macroexpand_1_Ret), f_eq(Eq_Param, Macroexpand_1_Ret, TrueResult101), IFTEST92=TrueResult101;IFTEST92=[]), (IFTEST92\==[]->f_gensym(Sym_Init105), LEnv104=[bv(sys_sym, Sym_Init105)|AEnv], sf_push(LEnv104, [list, sys_sym, [cadr, sys_l]], sys_bindings, Bindings), sf_push(LEnv104, [list, [quote, setq], [car, sys_l], sys_sym], sys_forms, LetResult103), _10376=LetResult103;LEnv108=[bv(sys_dummies, []), bv(sys_vals, []), bv(sys_newval, []), bv(sys_setter, []), bv(sys_getter, [])|AEnv], get_var(LEnv108, sys_l, L_Get110), f_car(L_Get110, Car_Ret174), get_var(LEnv108, sys_env, Env_Get109), f_macroexpand_1([Car_Ret174, Env_Get109], Setf_expansion_Param), get_var(LEnv108, sys_env, Env_Get111), f_get_setf_expansion(Setf_expansion_Param, [Env_Get111], Setf_expansion_Ret), setq_from_values(LEnv108, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter]), sf_declare(LEnv108, [ignore, sys_getter], Sf_declare_Ret), get_var(LEnv108, sys_dummies, Dummies_Get115), get_var(LEnv108, sys_vals, Vals_Get116), BlockExitEnv=[bv(sys_d, Dummies_Get115), bv(sys_v, Vals_Get116)|LEnv108], catch((call_addr_block(BlockExitEnv, (push_label(do_label_4), get_var(BlockExitEnv, sys_d, IFTEST133), (IFTEST133==[]->throw(block_exit([], [])), _TBResult119=ThrowResult137;sf_push(BlockExitEnv, [list, [car, sys_d], [car, sys_v]], sys_bindings, Bindings157), get_var(BlockExitEnv, sys_d, D_Get139), f_cdr(D_Get139, D), get_var(BlockExitEnv, sys_v, V_Get140), f_cdr(V_Get140, V), set_var(BlockExitEnv, sys_d, D), set_var(BlockExitEnv, sys_v, V), goto(do_label_4, BlockExitEnv), _TBResult119=_GORES141)), [addr(addr_tagbody_4_do_label_4, do_label_4, '$unused', BlockExitEnv125, (get_var(BlockExitEnv125, sys_d, IFTEST120), (IFTEST120==[]->throw(block_exit([], [])), _TBResult119=ThrowResult124;sf_push(BlockExitEnv125, [list, [car, sys_d], [car, sys_v]], sys_bindings, Sf_push_Ret), get_var(BlockExitEnv125, sys_d, D_Get126), f_cdr(D_Get126, Cdr_Ret), get_var(BlockExitEnv125, sys_v, V_Get127), f_cdr(V_Get127, Cdr_Ret179), set_var(BlockExitEnv125, sys_d, Cdr_Ret), set_var(BlockExitEnv125, sys_v, Cdr_Ret179), goto(do_label_4, BlockExitEnv125), _TBResult119=_GORES128)))]), []=LetResult113), block_exit([], LetResult113), true), sf_push(LEnv108, [list, [car, sys_newval], [cadr, sys_l]], sys_bindings, Bindings160), sf_push(LEnv108, sys_setter, sys_forms, LetResult107), _10376=LetResult107), get_var(AEnv, sys_l, L_Get148), f_cddr(L_Get148, L), set_var(AEnv, sys_l, L), goto(do_label_2, AEnv), _TBResult=_GORES149)),
912
913 [ addr(addr_tagbody_2_do_label_2,
914 do_label_2,
915 '$unused',
916 AEnv,
917 (get_var(AEnv, sys_l, L_Get), (s3q:is_endp(L_Get)->get_var(AEnv, sys_bindings, Reverse_Param165), f_reverse(Reverse_Param165, Reverse_Ret180), get_var(AEnv, sys_forms, Get_var_Ret), Reverse_Param166=[[]|Get_var_Ret], f_reverse(Reverse_Param166, Reverse_Ret182), f_list_xx(let_xx, [Reverse_Ret180, Reverse_Ret182], List_xx_Ret), throw(block_exit([], List_xx_Ret)), _11992=ThrowResult;get_var(AEnv, sys_l, L_Get24), f_car(L_Get24, PredArgResult26), (is_symbolp(PredArgResult26)->get_var(AEnv, sys_l, L_Get27), f_car(L_Get27, Eq_Param167), get_var(AEnv, sys_l, L_Get29), f_car(L_Get29, Car_Ret184), get_var(AEnv, sys_env, Get_var_Ret185), f_macroexpand_1([Car_Ret184, Get_var_Ret185], Macroexpand_1_Ret186), f_eq(Eq_Param167, Macroexpand_1_Ret186, Eq_Ret), IFTEST21=Eq_Ret;IFTEST21=[]), (IFTEST21\==[]->f_gensym(Gensym_Ret), LEnv33=[bv(sys_sym, Gensym_Ret)|AEnv], sf_push(LEnv33, [list, sys_sym, [cadr, sys_l]], sys_bindings, Sf_push_Ret189), sf_push(LEnv33, [list, [quote, setq], [car, sys_l], sys_sym], sys_forms, LetResult32), _12120=LetResult32;LEnv37=[bv(sys_dummies, []), bv(sys_vals, []), bv(sys_newval, []), bv(sys_setter, []), bv(sys_getter, [])|AEnv], get_var(LEnv37, sys_l, L_Get39), f_car(L_Get39, Car_Ret190), get_var(LEnv37, sys_env, Env_Get38), f_macroexpand_1([Car_Ret190, Env_Get38], Setf_expansion_Param168), get_var(LEnv37, sys_env, Env_Get40), f_get_setf_expansion(Setf_expansion_Param168, [Env_Get40], Setf_expansion_Ret191), setq_from_values(LEnv37, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter]), sf_declare(LEnv37, [ignore, sys_getter], Sf_declare_Ret192), get_var(LEnv37, sys_dummies, Dummies_Get), get_var(LEnv37, sys_vals, Vals_Get), BlockExitEnv=[bv(sys_d, Dummies_Get), bv(sys_v, Vals_Get)|LEnv37], catch((call_addr_block(BlockExitEnv, (push_label(do_label_3), get_var(BlockExitEnv, sys_d, IFTEST62), (IFTEST62==[]->throw(block_exit([], [])), _TBResult48=ThrowResult66;sf_push(BlockExitEnv, [list, [car, sys_d], [car, sys_v]], sys_bindings, Sf_push_Ret193), get_var(BlockExitEnv, sys_d, D_Get68), f_cdr(D_Get68, Cdr_Ret194), get_var(BlockExitEnv, sys_v, V_Get69), f_cdr(V_Get69, Cdr_Ret195), set_var(BlockExitEnv, sys_d, Cdr_Ret194), set_var(BlockExitEnv, sys_v, Cdr_Ret195), goto(do_label_3, BlockExitEnv), _TBResult48=_GORES70)), [addr(addr_tagbody_3_do_label_3, do_label_3, '$unused', BlockExitEnv54, (get_var(BlockExitEnv54, sys_d, IFTEST49), (IFTEST49==[]->throw(block_exit([], [])), _TBResult48=ThrowResult53;sf_push(BlockExitEnv54, [list, [car, sys_d], [car, sys_v]], sys_bindings, Sf_push_Ret196), get_var(BlockExitEnv54, sys_d, D_Get55), f_cdr(D_Get55, Cdr_Ret197), get_var(BlockExitEnv54, sys_v, Cdr_Param), f_cdr(Cdr_Param, Cdr_Ret198), set_var(BlockExitEnv54, sys_d, Cdr_Ret197), set_var(BlockExitEnv54, sys_v, Cdr_Ret198), goto(do_label_3, BlockExitEnv54), _TBResult48=_GORES)))]), []=LetResult42), block_exit([], LetResult42), true), sf_push(LEnv37, [list, [car, sys_newval], [cadr, sys_l]], sys_bindings, Sf_push_Ret199), sf_push(LEnv37, sys_setter, sys_forms, LetResult36), _12120=LetResult36), get_var(AEnv, sys_l, L_Get77), f_cddr(L_Get77, Cddr_Ret), set_var(AEnv, sys_l, Cddr_Ret), goto(do_label_2, AEnv), _11992=_GORES78)))
918 ]),
919 []=LetResult
920 ),
921 block_exit([], LetResult),
922 true)
923 ),
924 LetResult=MFResult
925 ),
926 block_exit(psetq, MFResult),
927 true).
928:- set_opv(mf_psetq, type_of, sys_macro),
929 set_opv(psetq, symbol_function, mf_psetq),
930 DefMacroResult=psetq. 931/*
932:- side_effect(assert_lsp(psetq,
933 lambda_def(defmacro,
934 psetq,
935 mf_psetq,
936
937 [ c38_environment,
938 sys_env,
939 c38_rest,
940 sys_args
941 ],
942
943 [
944 [ do,
945
946 [ [sys_l, sys_args, [cddr, sys_l]],
947 [sys_forms, []],
948 [sys_bindings, []]
949 ],
950
951 [ [endp, sys_l],
952
953 [ list_xx,
954 [quote, let_xx],
955 [reverse, sys_bindings],
956 [reverse, [cons, [], sys_forms]]
957 ]
958 ],
959
960 [ if,
961
962 [ and,
963 [symbolp, [car, sys_l]],
964
965 [ eq,
966 [car, sys_l],
967
968 [ macroexpand_1,
969 [car, sys_l],
970 sys_env
971 ]
972 ]
973 ],
974
975 [ let,
976 [[sys_sym, [gensym]]],
977
978 [ push,
979 [list, sys_sym, [cadr, sys_l]],
980 sys_bindings
981 ],
982
983 [ push,
984
985 [ list,
986 [quote, setq],
987 [car, sys_l],
988 sys_sym
989 ],
990 sys_forms
991 ]
992 ],
993
994 [ multiple_value_bind,
995
996 [ sys_dummies,
997 sys_vals,
998 sys_newval,
999 sys_setter,
1000 sys_getter
1001 ],
1002
1003 [ get_setf_expansion,
1004
1005 [ macroexpand_1,
1006 [car, sys_l],
1007 sys_env
1008 ],
1009 sys_env
1010 ],
1011 [declare, [ignore, sys_getter]],
1012
1013 [ do,
1014
1015 [
1016 [ sys_d,
1017 sys_dummies,
1018 [cdr, sys_d]
1019 ],
1020 [sys_v, sys_vals, [cdr, sys_v]]
1021 ],
1022 [[null, sys_d]],
1023
1024 [ push,
1025
1026 [ list,
1027 [car, sys_d],
1028 [car, sys_v]
1029 ],
1030 sys_bindings
1031 ]
1032 ],
1033
1034 [ push,
1035
1036 [ list,
1037 [car, sys_newval],
1038 [cadr, sys_l]
1039 ],
1040 sys_bindings
1041 ],
1042 [push, sys_setter, sys_forms]
1043 ]
1044 ]
1045 ]
1046 ]))).
1047*/
1048/*
1049:- side_effect(assert_lsp(psetq,
1050 arglist_info(psetq,
1051 mf_psetq,
1052
1053 [ c38_environment,
1054 sys_env,
1055 c38_rest,
1056 sys_args
1057 ],
1058 arginfo{ all:0,
1059 allow_other_keys:0,
1060 aux:0,
1061 body:0,
1062 complex:[environment, rest],
1063 env:[sys_env],
1064 key:0,
1065 names:[sys_env, sys_args],
1066 opt:0,
1067 req:0,
1068 rest:[sys_args],
1069 sublists:0,
1070 whole:0
1071 }))).
1072*/
1073/*
1074:- side_effect(assert_lsp(psetq, init_args(0, mf_psetq))).
1075*/
1076/*
1077(defmacro setf (&rest pairs &environment env)
1078 (let ((nargs (length pairs)))
1079 (assert (evenp nargs))
1080 (cond
1081 ((zerop nargs) nil)
1082 ((= nargs 2)
1083 (let ((place (car pairs))
1084 (value-form (cadr pairs)))
1085 (cond
1086 ((symbolp place)
1087 `(setq ,place ,value-form))
1088 ((consp place)
1089 (if (eq (car place) 'the)
1090 `(setf ,(caddr place) (the ,(cadr place) ,value-form))
1091 (multiple-value-bind (temps vars newvals setter getter)
1092 (get-setf-expansion place env)
1093 (declare (ignore getter))
1094 `(let (,@(mapcar #'list temps vars))
1095 (multiple-value-bind ,newvals ,value-form
1096 ,setter))))))))
1097 (t
1098 (do* ((pairs pairs (cddr pairs))
1099 (setfs (list 'progn))
1100 (splice setfs))
1101 ((endp pairs) setfs)
1102 (setq splice (cdr (rplacd splice
1103 `((setf ,(car pairs) ,(cadr pairs)))))))))))
1104*/
1105
1106/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:3126 **********************/
1107:-lisp_compile_to_prolog(pkg_sys,[defmacro,setf,['&rest',pairs,'&environment',env],[let,[[nargs,[length,pairs]]],[assert,[evenp,nargs]],[cond,[[zerop,nargs],[]],[[=,nargs,2],[let,[[place,[car,pairs]],['value-form',[cadr,pairs]]],[cond,[[symbolp,place],['#BQ',[setq,['#COMMA',place],['#COMMA','value-form']]]],[[consp,place],[if,[eq,[car,place],[quote,the]],['#BQ',[setf,['#COMMA',[caddr,place]],[the,['#COMMA',[cadr,place]],['#COMMA','value-form']]]],['multiple-value-bind',[temps,vars,newvals,setter,getter],['get-setf-expansion',place,env],[declare,[ignore,getter]],['#BQ',[let,[['#BQ-COMMA-ELIPSE',[mapcar,function(list),temps,vars]]],['multiple-value-bind',['#COMMA',newvals],['#COMMA','value-form'],['#COMMA',setter]]]]]]]]]],[t,['do*',[[pairs,pairs,[cddr,pairs]],[setfs,[list,[quote,progn]]],[splice,setfs]],[[endp,pairs],setfs],[setq,splice,[cdr,[rplacd,splice,['#BQ',[[setf,['#COMMA',[car,pairs]],['#COMMA',[cadr,pairs]]]]]]]]]]]]])
1108/*
1109% macroexpand:-[assert,[evenp,sys_nargs]].
1110*/
1111/*
1112% into:-[do,[],[[evenp,sys_nargs],[]],[multiple_value_setq,[],[apply,[quote,sys_assert_places],[quote,[]],[list],'$ARRAY'([*],claz_base_character,"The assertion ~:@(~S~) failed."),[quote,[evenp,sys_nargs]],[]]]].
1113*/
1114/*
1115% macroexpand:-[psetq].
1116*/
1117/*
1118% into:-[let_xx,[],[]].
1119*/
1120/*
1121% macroexpand:-[psetq].
1122*/
1123/*
1124% into:-[let_xx,[],[]].
1125*/
1126/*
1127:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1128 setf,
1129 kw_special,
1130 sf_setf)).
1131*/
1132wl:lambda_def(defmacro, setf, mf_setf, [c38_rest, sys_pairs, c38_environment, sys_env], [[let, [[sys_nargs, [length, sys_pairs]]], [assert, [evenp, sys_nargs]], [cond, [[zerop, sys_nargs], []], [[=, sys_nargs, 2], [let, [[sys_place, [car, sys_pairs]], [sys_value_form, [cadr, sys_pairs]]], [cond, [[symbolp, sys_place], ['#BQ', [setq, ['#COMMA', sys_place], ['#COMMA', sys_value_form]]]], [[consp, sys_place], [if, [eq, [car, sys_place], [quote, the]], ['#BQ', [setf, ['#COMMA', [caddr, sys_place]], [the, ['#COMMA', [cadr, sys_place]], ['#COMMA', sys_value_form]]]], [multiple_value_bind, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter], [get_setf_expansion, sys_place, sys_env], [declare, [ignore, sys_getter]], ['#BQ', [let, [['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_temps, sys_vars]]], [multiple_value_bind, ['#COMMA', sys_newvals], ['#COMMA', sys_value_form], ['#COMMA', sys_setter]]]]]]]]]], [t, [do_xx, [[sys_pairs, sys_pairs, [cddr, sys_pairs]], [sys_setfs, [list, [quote, progn]]], [sys_splice, sys_setfs]], [[endp, sys_pairs], sys_setfs], [setq, sys_splice, [cdr, [rplacd, sys_splice, ['#BQ', [[setf, ['#COMMA', [car, sys_pairs]], ['#COMMA', [cadr, sys_pairs]]]]]]]]]]]]]).
1133wl:arglist_info(setf, mf_setf, [c38_rest, sys_pairs, c38_environment, sys_env], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:[rest, environment], env:[sys_env], key:0, names:[sys_pairs, sys_env], opt:0, req:0, rest:[sys_pairs], sublists:0, whole:0}).
1134wl: init_args(0, mf_setf).
1135
1140sf_setf(Env_In, RestNKeys, FResult) :-
1141 mf_setf([setf|RestNKeys], Env_In, MFResult),
1142 f_sys_env_eval(Env_In, MFResult, FResult).
1147mf_setf([setf|RestNKeys], Env_In, MFResult) :-
1148 nop(defmacro),
1149 GEnv=[bv(sys_pairs, RestNKeys), bv(sys_env, Env_In)],
1150 catch(( ( get_var(GEnv, sys_pairs, Pairs_Get),
1151 f_length(Pairs_Get, Nargs_Init),
1152 BlockExitEnv=[bv(sys_nargs, Nargs_Init)|GEnv],
1153 catch(( call_addr_block(BlockExitEnv,
1154 (push_label(do_label_5), get_var(BlockExitEnv, sys_nargs, Nargs_Get25), (mth:is_evenp(Nargs_Get25)->throw(block_exit([], [])), _TBResult=ThrowResult29;CAR=[], f_apply(sys_assert_places, [[], CAR, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [evenp, sys_nargs], []], Apply_Ret), setq_from_values(BlockExitEnv, []), goto(do_label_5, BlockExitEnv), _TBResult=_GORES31)),
1155
1156 [ addr(addr_tagbody_5_do_label_5,
1157 do_label_5,
1158 '$unused',
1159 BlockExitEnv,
1160 (get_var(BlockExitEnv, sys_nargs, Nargs_Get), (mth:is_evenp(Nargs_Get)->throw(block_exit([], [])), _9542=ThrowResult;CAR144=[], f_apply(sys_assert_places, [[], CAR144, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [evenp, sys_nargs], []], Apply_Ret143), setq_from_values(BlockExitEnv, []), goto(do_label_5, BlockExitEnv), _9542=_GORES)))
1161 ]),
1162 []=Block_exit_Ret
1163 ),
1164 block_exit([], Block_exit_Ret),
1165 true),
1166 get_var(BlockExitEnv, sys_nargs, Nargs_Get36),
1167 ( mth:is_zerop(Nargs_Get36)
1168 -> LetResult=[]
1169 ; get_var(BlockExitEnv, sys_nargs, Nargs_Get40),
1170 ( Nargs_Get40=:=2
1171 -> get_var(BlockExitEnv, sys_pairs, Pairs_Get46),
1172 f_car(Pairs_Get46, Place_Init),
1173 get_var(BlockExitEnv, sys_pairs, Pairs_Get47),
1174 f_cadr(Pairs_Get47, Value_form_Init),
1175 LEnv45=[bv(sys_place, Place_Init), bv(sys_value_form, Value_form_Init)|BlockExitEnv],
1176 get_var(LEnv45, sys_place, Place_Get),
1177 ( is_symbolp(Place_Get)
1178 -> get_var(LEnv45, sys_place, Place_Get54),
1179 get_var(LEnv45, sys_value_form, Value_form_Get),
1180 LetResult44=[setq, Place_Get54, Value_form_Get]
1181 ; get_var(LEnv45, sys_place, Place_Get57),
1182 ( c0nz:is_consp(Place_Get57)
1183 -> get_var(LEnv45, sys_place, Place_Get61),
1184 f_car(Place_Get61, PredArg1Result63),
1185 ( is_eq(PredArg1Result63, the)
1186 -> get_var(LEnv45, sys_place, Place_Get64),
1187 f_caddr(Place_Get64, Caddr_Ret),
1188 get_var(LEnv45, sys_place, Place_Get65),
1189 f_cadr(Place_Get65, Cadr_Ret),
1190 get_var(LEnv45,
1191 sys_value_form,
1192 Value_form_Get66),
1193 TrueResult77=[setf, Caddr_Ret, [the, Cadr_Ret, Value_form_Get66]]
1194 ; LEnv69=[bv(sys_temps, []), bv(sys_vars, []), bv(sys_newvals, []), bv(sys_setter, []), bv(sys_getter, [])|LEnv45],
1195 get_var(LEnv69, sys_env, Env_Get),
1196 get_var(LEnv69, sys_place, Place_Get70),
1197 f_get_setf_expansion(Place_Get70,
1198 [Env_Get],
1199 Setf_expansion_Ret),
1200 setq_from_values(LEnv69,
1201
1202 [ sys_temps,
1203 sys_vars,
1204 sys_newvals,
1205 sys_setter,
1206 sys_getter
1207 ]),
1208 sf_declare(LEnv69,
1209 [ignore, sys_getter],
1210 Sf_declare_Ret),
1211 get_var(LEnv69, sys_temps, Temps_Get),
1212 get_var(LEnv69, sys_vars, Vars_Get),
1213 f_mapcar(f_list,
1214 [Temps_Get, Vars_Get],
1215 Mapcar_Ret),
1216 get_var(LEnv69, sys_newvals, Newvals_Get),
1217 get_var(LEnv69, sys_setter, Setter_Get),
1218 get_var(LEnv69,
1219 sys_value_form,
1220 Value_form_Get75),
1221 TrueResult77=[let, Mapcar_Ret, [multiple_value_bind, Newvals_Get, Value_form_Get75, Setter_Get]]
1222 ),
1223 ElseResult79=TrueResult77
1224 ; ElseResult78=[],
1225 ElseResult79=ElseResult78
1226 ),
1227 LetResult44=ElseResult79
1228 ),
1229 ElseResult132=LetResult44
1230 ; get_var(BlockExitEnv, sys_pairs, Pairs_Get83),
1231 LEnv82=[bv(sys_pairs, Pairs_Get83)|BlockExitEnv],
1232 Setfs_Init=[progn],
1233 LEnv87=[bv(sys_setfs, Setfs_Init)|LEnv82],
1234 get_var(LEnv87, sys_setfs, Setfs_Get),
1235 AEnv=[bv(sys_splice, Setfs_Get)|LEnv87],
1236 catch(( call_addr_block(AEnv,
1237 (push_label(do_label_6), get_var(AEnv, sys_pairs, Pairs_Get114), (s3q:is_endp(Pairs_Get114)->get_var(AEnv, sys_setfs, RetResult117), throw(block_exit([], RetResult117)), _TBResult94=ThrowResult118;get_var(AEnv, sys_pairs, Pairs_Get123), get_var(AEnv, sys_splice, Splice_Get122), f_car(Pairs_Get123, Car_Ret), get_var(AEnv, sys_pairs, Pairs_Get124), f_cadr(Pairs_Get124, Cadr_Ret152), f_rplacd(Splice_Get122, [[setf, Car_Ret, Cadr_Ret152]], Cdr_Param), f_cdr(Cdr_Param, Splice), set_var(AEnv, sys_splice, Splice), get_var(AEnv, sys_pairs, Pairs_Get125), f_cddr(Pairs_Get125, Pairs), set_var(AEnv, sys_pairs, Pairs), goto(do_label_6, AEnv), _TBResult94=_GORES126)),
1238
1239 [ addr(addr_tagbody_6_do_label_6,
1240 do_label_6,
1241 '$unused',
1242 AEnv,
1243 (get_var(AEnv, sys_pairs, Pairs_Get96), (s3q:is_endp(Pairs_Get96)->get_var(AEnv, sys_setfs, RetResult99), throw(block_exit([], RetResult99)), _TBResult94=ThrowResult100;get_var(AEnv, sys_pairs, Pairs_Get105), get_var(AEnv, sys_splice, Rplacd_Param), f_car(Pairs_Get105, Car_Ret153), get_var(AEnv, sys_pairs, Pairs_Get106), f_cadr(Pairs_Get106, Cadr_Ret154), f_rplacd(Rplacd_Param, [[setf, Car_Ret153, Cadr_Ret154]], Cdr_Param140), f_cdr(Cdr_Param140, Cdr_Ret), set_var(AEnv, sys_splice, Cdr_Ret), get_var(AEnv, sys_pairs, Pairs_Get107), f_cddr(Pairs_Get107, Cddr_Ret), set_var(AEnv, sys_pairs, Cddr_Ret), goto(do_label_6, AEnv), _TBResult94=_GORES108)))
1244 ]),
1245 []=LetResult90
1246 ),
1247 block_exit([], LetResult90),
1248 true),
1249 ElseResult132=LetResult90
1250 ),
1251 LetResult=ElseResult132
1252 )
1253 ),
1254 LetResult=MFResult
1255 ),
1256 block_exit(setf, MFResult),
1257 true).
1258:- set_opv(mf_setf, type_of, sys_macro),
1259 set_opv(setf, symbol_function, mf_setf),
1260 DefMacroResult=setf. 1261/*
1262:- side_effect(assert_lsp(setf,
1263 lambda_def(defmacro,
1264 setf,
1265 mf_setf,
1266
1267 [ c38_rest,
1268 sys_pairs,
1269 c38_environment,
1270 sys_env
1271 ],
1272
1273 [
1274 [ let,
1275 [[sys_nargs, [length, sys_pairs]]],
1276 [assert, [evenp, sys_nargs]],
1277
1278 [ cond,
1279 [[zerop, sys_nargs], []],
1280
1281 [ [=, sys_nargs, 2],
1282
1283 [ let,
1284
1285 [ [sys_place, [car, sys_pairs]],
1286
1287 [ sys_value_form,
1288 [cadr, sys_pairs]
1289 ]
1290 ],
1291
1292 [ cond,
1293
1294 [ [symbolp, sys_place],
1295
1296 [ '#BQ',
1297
1298 [ setq,
1299 ['#COMMA', sys_place],
1300
1301 [ '#COMMA',
1302 sys_value_form
1303 ]
1304 ]
1305 ]
1306 ],
1307
1308 [ [consp, sys_place],
1309
1310 [ if,
1311
1312 [ eq,
1313 [car, sys_place],
1314 [quote, the]
1315 ],
1316
1317 [ '#BQ',
1318
1319 [ setf,
1320
1321 [ '#COMMA',
1322 [caddr, sys_place]
1323 ],
1324
1325 [ the,
1326
1327 [ '#COMMA',
1328 [cadr, sys_place]
1329 ],
1330
1331 [ '#COMMA',
1332 sys_value_form
1333 ]
1334 ]
1335 ]
1336 ],
1337
1338 [ multiple_value_bind,
1339
1340 [ sys_temps,
1341 sys_vars,
1342 sys_newvals,
1343 sys_setter,
1344 sys_getter
1345 ],
1346
1347 [ get_setf_expansion,
1348 sys_place,
1349 sys_env
1350 ],
1351
1352 [ declare,
1353 [ignore, sys_getter]
1354 ],
1355
1356 [ '#BQ',
1357
1358 [ let,
1359
1360 [
1361 [ '#BQ-COMMA-ELIPSE',
1362
1363 [ mapcar,
1364 function(list),
1365 sys_temps,
1366 sys_vars
1367 ]
1368 ]
1369 ],
1370
1371 [ multiple_value_bind,
1372
1373 [ '#COMMA',
1374 sys_newvals
1375 ],
1376
1377 [ '#COMMA',
1378 sys_value_form
1379 ],
1380
1381 [ '#COMMA',
1382 sys_setter
1383 ]
1384 ]
1385 ]
1386 ]
1387 ]
1388 ]
1389 ]
1390 ]
1391 ]
1392 ],
1393
1394 [ t,
1395
1396 [ do_xx,
1397
1398 [
1399 [ sys_pairs,
1400 sys_pairs,
1401 [cddr, sys_pairs]
1402 ],
1403
1404 [ sys_setfs,
1405 [list, [quote, progn]]
1406 ],
1407 [sys_splice, sys_setfs]
1408 ],
1409 [[endp, sys_pairs], sys_setfs],
1410
1411 [ setq,
1412 sys_splice,
1413
1414 [ cdr,
1415
1416 [ rplacd,
1417 sys_splice,
1418
1419 [ '#BQ',
1420
1421 [
1422 [ setf,
1423
1424 [ '#COMMA',
1425 [car, sys_pairs]
1426 ],
1427
1428 [ '#COMMA',
1429 [cadr, sys_pairs]
1430 ]
1431 ]
1432 ]
1433 ]
1434 ]
1435 ]
1436 ]
1437 ]
1438 ]
1439 ]
1440 ]
1441 ]))).
1442*/
1443/*
1444:- side_effect(assert_lsp(setf,
1445 arglist_info(setf,
1446 mf_setf,
1447
1448 [ c38_rest,
1449 sys_pairs,
1450 c38_environment,
1451 sys_env
1452 ],
1453 arginfo{ all:0,
1454 allow_other_keys:0,
1455 aux:0,
1456 body:0,
1457 complex:[rest, environment],
1458 env:[sys_env],
1459 key:0,
1460 names:[sys_pairs, sys_env],
1461 opt:0,
1462 req:0,
1463 rest:[sys_pairs],
1464 sublists:0,
1465 whole:0
1466 }))).
1467*/
1468/*
1469:- side_effect(assert_lsp(setf, init_args(0, mf_setf))).
1470*/
1471/*
1472(defmacro psetf (&rest pairs &environment env)
1473 (let ((nargs (length pairs)))
1474 (assert (evenp nargs))
1475 (if (< nargs 4)
1476 `(progn (setf ,@pairs) nil)
1477 (let ((setters nil))
1478 (labels ((expand (pairs)
1479 (if pairs
1480 (multiple-value-bind (temps vars newvals setter getter)
1481 (get-setf-expansion (car pairs) env)
1482 (declare (ignore getter))
1483 (setq setters (cons setter setters))
1484 `(let (,@(mapcar #'list temps vars))
1485 (multiple-value-bind ,newvals ,(cadr pairs)
1486 ,(expand (cddr pairs)))))
1487 `(progn ,@setters nil))))
1488 (expand pairs))))))
1489
1490*/
1491
1492/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:4436 **********************/
1493:-lisp_compile_to_prolog(pkg_sys,[defmacro,psetf,['&rest',pairs,'&environment',env],[let,[[nargs,[length,pairs]]],[assert,[evenp,nargs]],[if,[<,nargs,4],['#BQ',[progn,[setf,['#BQ-COMMA-ELIPSE',pairs]],[]]],[let,[[setters,[]]],[labels,[[expand,[pairs],[if,pairs,['multiple-value-bind',[temps,vars,newvals,setter,getter],['get-setf-expansion',[car,pairs],env],[declare,[ignore,getter]],[setq,setters,[cons,setter,setters]],['#BQ',[let,[['#BQ-COMMA-ELIPSE',[mapcar,function(list),temps,vars]]],['multiple-value-bind',['#COMMA',newvals],['#COMMA',[cadr,pairs]],['#COMMA',[expand,[cddr,pairs]]]]]]],['#BQ',[progn,['#BQ-COMMA-ELIPSE',setters],[]]]]]],[expand,pairs]]]]]])
1494/*
1495% macroexpand:-[assert,[evenp,sys_nargs]].
1496*/
1497/*
1498% into:-[do,[],[[evenp,sys_nargs],[]],[multiple_value_setq,[],[apply,[quote,sys_assert_places],[quote,[]],[list],'$ARRAY'([*],claz_base_character,"The assertion ~:@(~S~) failed."),[quote,[evenp,sys_nargs]],[]]]].
1499*/
1500/*
1501% macroexpand:-[psetq].
1502*/
1503/*
1504% into:-[let_xx,[],[]].
1505*/
1506/*
1507% macroexpand:-[psetq].
1508*/
1509/*
1510% into:-[let_xx,[],[]].
1511*/
1512/*
1513:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1514 sys_expand,
1515 kw_function,
1516 f_sys_expand)).
1517*/
1518/*
1519:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1520 sys_expand,
1521 kw_function,
1522 f_sys_expand)).
1523*/
1524/*
1525:- side_effect(generate_function_or_macro_name(
1526 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
1527 name='GLOBAL',
1528 environ=env_1
1529 ],
1530 psetf,
1531 kw_special,
1532 sf_psetf)).
1533*/
1534wl:lambda_def(defmacro, psetf, mf_psetf, [c38_rest, sys_pairs, c38_environment, sys_env], [[let, [[sys_nargs, [length, sys_pairs]]], [assert, [evenp, sys_nargs]], [if, [<, sys_nargs, 4], ['#BQ', [progn, [setf, ['#BQ-COMMA-ELIPSE', sys_pairs]], []]], [let, [[sys_setters, []]], [labels, [[sys_expand, [sys_pairs], [if, sys_pairs, [multiple_value_bind, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter], [get_setf_expansion, [car, sys_pairs], sys_env], [declare, [ignore, sys_getter]], [setq, sys_setters, [cons, sys_setter, sys_setters]], ['#BQ', [let, [['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_temps, sys_vars]]], [multiple_value_bind, ['#COMMA', sys_newvals], ['#COMMA', [cadr, sys_pairs]], ['#COMMA', [sys_expand, [cddr, sys_pairs]]]]]]], ['#BQ', [progn, ['#BQ-COMMA-ELIPSE', sys_setters], []]]]]], [sys_expand, sys_pairs]]]]]]).
1535wl:arglist_info(psetf, mf_psetf, [c38_rest, sys_pairs, c38_environment, sys_env], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:[rest, environment], env:[sys_env], key:0, names:[sys_pairs, sys_env], opt:0, req:0, rest:[sys_pairs], sublists:0, whole:0}).
1536wl: init_args(0, mf_psetf).
1537
1542sf_psetf(Env_In, RestNKeys, FResult) :-
1543 mf_psetf([psetf|RestNKeys], Env_In, MFResult),
1544 f_sys_env_eval(Env_In, MFResult, FResult).
1549mf_psetf([psetf|RestNKeys], Env_In, MFResult) :-
1550 nop(defmacro),
1551 GEnv=[bv(sys_pairs, RestNKeys), bv(sys_env, Env_In)],
1552 catch(( ( get_var(GEnv, sys_pairs, Pairs_Get),
1553 f_length(Pairs_Get, Nargs_Init),
1554 BlockExitEnv=[bv(sys_nargs, Nargs_Init)|GEnv],
1555 catch(( call_addr_block(BlockExitEnv,
1556 (push_label(do_label_7), get_var(BlockExitEnv, sys_nargs, Nargs_Get25), (mth:is_evenp(Nargs_Get25)->throw(block_exit([], [])), _TBResult=ThrowResult29;CAR=[], f_apply(sys_assert_places, [[], CAR, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [evenp, sys_nargs], []], Apply_Ret), setq_from_values(BlockExitEnv, []), goto(do_label_7, BlockExitEnv), _TBResult=_GORES31)),
1557
1558 [ addr(addr_tagbody_7_do_label_7,
1559 do_label_7,
1560 '$unused',
1561 BlockExitEnv,
1562 (get_var(BlockExitEnv, sys_nargs, Nargs_Get), (mth:is_evenp(Nargs_Get)->throw(block_exit([], [])), _8674=ThrowResult;CAR78=[], f_apply(sys_assert_places, [[], CAR78, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [evenp, sys_nargs], []], Apply_Ret77), setq_from_values(BlockExitEnv, []), goto(do_label_7, BlockExitEnv), _8674=_GORES)))
1563 ]),
1564 []=Block_exit_Ret
1565 ),
1566 block_exit([], Block_exit_Ret),
1567 true),
1568 get_var(BlockExitEnv, sys_nargs, Nargs_Get36),
1569 ( Nargs_Get36<4
1570 -> get_var(BlockExitEnv, sys_pairs, Pairs_Get39),
1571 LetResult=[progn, [setf|Pairs_Get39], []]
1572 ; LEnv42=[bv(sys_setters, [])|BlockExitEnv],
1573 assert_lsp(sys_expand,
1574 wl:lambda_def(defun, sys_expand, f_sys_expand1, [sys_pairs], [[if, sys_pairs, [multiple_value_bind, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter], [get_setf_expansion, [car, sys_pairs], sys_env], [declare, [ignore, sys_getter]], [setq, sys_setters, [cons, sys_setter, sys_setters]], ['#BQ', [let, [['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_temps, sys_vars]]], [multiple_value_bind, ['#COMMA', sys_newvals], ['#COMMA', [cadr, sys_pairs]], ['#COMMA', [sys_expand, [cddr, sys_pairs]]]]]]], ['#BQ', [progn, ['#BQ-COMMA-ELIPSE', sys_setters], []]]]])),
1575 assert_lsp(sys_expand,
1576 wl:arglist_info(sys_expand, f_sys_expand1, [sys_pairs], arginfo{all:[sys_pairs], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_pairs], opt:0, req:[sys_pairs], rest:0, sublists:0, whole:0})),
1577 assert_lsp(sys_expand, wl:init_args(1, f_sys_expand1)),
1578 assert_lsp(sys_expand,
1579 (f_sys_expand1(Pairs_In46, RestNKeys45, FnResult):-GEnv71=[bv(sys_pairs, Pairs_In46)], catch(((get_var(GEnv71, sys_pairs, IFTEST47), (IFTEST47\==[]->LEnv52=[bv(sys_temps, []), bv(sys_vars, []), bv(sys_newvals, []), bv(sys_setter, []), bv(sys_getter, [])|GEnv71], get_var(LEnv52, sys_pairs, Pairs_Get53), f_car(Pairs_Get53, Setf_expansion_Param), get_var(LEnv52, sys_env, Env_Get), f_get_setf_expansion(Setf_expansion_Param, [Env_Get], Setf_expansion_Ret), setq_from_values(LEnv52, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter]), sf_declare(LEnv52, [ignore, sys_getter], Sf_declare_Ret), get_var(LEnv52, sys_setter, Setter_Get), get_var(LEnv52, sys_setters, Setters_Get), Setters=[Setter_Get|Setters_Get], set_var(LEnv52, sys_setters, Setters), get_var(LEnv52, sys_temps, Temps_Get), get_var(LEnv52, sys_vars, Vars_Get), f_mapcar(f_list, [Temps_Get, Vars_Get], Mapcar_Ret), get_var(LEnv52, sys_newvals, Newvals_Get), get_var(LEnv52, sys_pairs, Pairs_Get61), f_cadr(Pairs_Get61, Cadr_Ret), get_var(LEnv52, sys_pairs, Pairs_Get62), f_cddr(Pairs_Get62, Expand_Param), f_sys_expand(Expand_Param, Expand_Ret), _8990=[let, Mapcar_Ret, [multiple_value_bind, Newvals_Get, Cadr_Ret, Expand_Ret]];get_var(GEnv71, sys_setters, Setters_Get63), bq_append([progn|Setters_Get63], [[]], ElseResult64), _8990=ElseResult64)), _8990=FnResult), block_exit(sys_expand, FnResult), true))),
1580 get_var(LEnv42, sys_pairs, Pairs_Get66),
1581 f_sys_expand1(Pairs_Get66, LetResult41),
1582 LetResult=LetResult41
1583 )
1584 ),
1585 LetResult=MFResult
1586 ),
1587 block_exit(psetf, MFResult),
1588 true).
1589:- set_opv(mf_psetf, type_of, sys_macro),
1590 set_opv(psetf, symbol_function, mf_psetf),
1591 DefMacroResult=psetf. 1592/*
1593:- side_effect(assert_lsp(psetf,
1594 lambda_def(defmacro,
1595 psetf,
1596 mf_psetf,
1597
1598 [ c38_rest,
1599 sys_pairs,
1600 c38_environment,
1601 sys_env
1602 ],
1603
1604 [
1605 [ let,
1606 [[sys_nargs, [length, sys_pairs]]],
1607 [assert, [evenp, sys_nargs]],
1608
1609 [ if,
1610 [<, sys_nargs, 4],
1611
1612 [ '#BQ',
1613
1614 [ progn,
1615
1616 [ setf,
1617
1618 [ '#BQ-COMMA-ELIPSE',
1619 sys_pairs
1620 ]
1621 ],
1622 []
1623 ]
1624 ],
1625
1626 [ let,
1627 [[sys_setters, []]],
1628
1629 [ labels,
1630
1631 [
1632 [ sys_expand,
1633 [sys_pairs],
1634
1635 [ if,
1636 sys_pairs,
1637
1638 [ multiple_value_bind,
1639
1640 [ sys_temps,
1641 sys_vars,
1642 sys_newvals,
1643 sys_setter,
1644 sys_getter
1645 ],
1646
1647 [ get_setf_expansion,
1648 [car, sys_pairs],
1649 sys_env
1650 ],
1651
1652 [ declare,
1653 [ignore, sys_getter]
1654 ],
1655
1656 [ setq,
1657 sys_setters,
1658
1659 [ cons,
1660 sys_setter,
1661 sys_setters
1662 ]
1663 ],
1664
1665 [ '#BQ',
1666
1667 [ let,
1668
1669 [
1670 [ '#BQ-COMMA-ELIPSE',
1671
1672 [ mapcar,
1673 function(list),
1674 sys_temps,
1675 sys_vars
1676 ]
1677 ]
1678 ],
1679
1680 [ multiple_value_bind,
1681
1682 [ '#COMMA',
1683 sys_newvals
1684 ],
1685
1686 [ '#COMMA',
1687 [cadr, sys_pairs]
1688 ],
1689
1690 [ '#COMMA',
1691
1692 [ sys_expand,
1693 [cddr, sys_pairs]
1694 ]
1695 ]
1696 ]
1697 ]
1698 ]
1699 ],
1700
1701 [ '#BQ',
1702
1703 [ progn,
1704
1705 [ '#BQ-COMMA-ELIPSE',
1706 sys_setters
1707 ],
1708 []
1709 ]
1710 ]
1711 ]
1712 ]
1713 ],
1714 [sys_expand, sys_pairs]
1715 ]
1716 ]
1717 ]
1718 ]
1719 ]))).
1720*/
1721/*
1722:- side_effect(assert_lsp(psetf,
1723 arglist_info(psetf,
1724 mf_psetf,
1725
1726 [ c38_rest,
1727 sys_pairs,
1728 c38_environment,
1729 sys_env
1730 ],
1731 arginfo{ all:0,
1732 allow_other_keys:0,
1733 aux:0,
1734 body:0,
1735 complex:[rest, environment],
1736 env:[sys_env],
1737 key:0,
1738 names:[sys_pairs, sys_env],
1739 opt:0,
1740 req:0,
1741 rest:[sys_pairs],
1742 sublists:0,
1743 whole:0
1744 }))).
1745*/
1746/*
1747:- side_effect(assert_lsp(psetf, init_args(0, mf_psetf))).
1748*/
1749/*
1750(defmacro shiftf (&rest places-and-newvalue &environment env)
1751 (let ((nargs (length places-and-newvalue)))
1752 (assert (>= nargs 2))
1753 (let ((place (car places-and-newvalue)))
1754 (multiple-value-bind (temps vars newvals setter getter)
1755 (get-setf-expansion place env)
1756 `(let (,@(mapcar #'list temps vars))
1757 (multiple-value-prog1 ,getter
1758 (multiple-value-bind ,newvals
1759 ,(if (= nargs 2)
1760 (cadr places-and-newvalue)
1761 `(shiftf ,@(cdr places-and-newvalue)))
1762 ,setter)))))))
1763
1764
1765*/
1766
1767/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:5459 **********************/
1768:-lisp_compile_to_prolog(pkg_sys,[defmacro,shiftf,['&rest','places-and-newvalue','&environment',env],[let,[[nargs,[length,'places-and-newvalue']]],[assert,[>=,nargs,2]],[let,[[place,[car,'places-and-newvalue']]],['multiple-value-bind',[temps,vars,newvals,setter,getter],['get-setf-expansion',place,env],['#BQ',[let,[['#BQ-COMMA-ELIPSE',[mapcar,function(list),temps,vars]]],['multiple-value-prog1',['#COMMA',getter],['multiple-value-bind',['#COMMA',newvals],['#COMMA',[if,[=,nargs,2],[cadr,'places-and-newvalue'],['#BQ',[shiftf,['#BQ-COMMA-ELIPSE',[cdr,'places-and-newvalue']]]]]],['#COMMA',setter]]]]]]]]])
1769/*
1770% macroexpand:-[assert,[>=,sys_nargs,2]].
1771*/
1772/*
1773% into:-[do,[],[[>=,sys_nargs,2],[]],[multiple_value_setq,[],[apply,[quote,sys_assert_places],[quote,[]],[list],'$ARRAY'([*],claz_base_character,"The assertion ~:@(~S~) failed."),[quote,[>=,sys_nargs,2]],[]]]].
1774*/
1775/*
1776% macroexpand:-[psetq].
1777*/
1778/*
1779% into:-[let_xx,[],[]].
1780*/
1781/*
1782% macroexpand:-[psetq].
1783*/
1784/*
1785% into:-[let_xx,[],[]].
1786*/
1787/*
1788:- side_effect(generate_function_or_macro_name(
1789 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
1790 name='GLOBAL',
1791 environ=env_1
1792 ],
1793 shiftf,
1794 kw_special,
1795 sf_shiftf)).
1796*/
1797wl:lambda_def(defmacro, shiftf, mf_shiftf, [c38_rest, sys_places_and_newvalue, c38_environment, sys_env], [[let, [[sys_nargs, [length, sys_places_and_newvalue]]], [assert, [>=, sys_nargs, 2]], [let, [[sys_place, [car, sys_places_and_newvalue]]], [multiple_value_bind, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter], [get_setf_expansion, sys_place, sys_env], ['#BQ', [let, [['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_temps, sys_vars]]], [multiple_value_prog1, ['#COMMA', sys_getter], [multiple_value_bind, ['#COMMA', sys_newvals], ['#COMMA', [if, [=, sys_nargs, 2], [cadr, sys_places_and_newvalue], ['#BQ', [shiftf, ['#BQ-COMMA-ELIPSE', [cdr, sys_places_and_newvalue]]]]]], ['#COMMA', sys_setter]]]]]]]]]).
1798wl:arglist_info(shiftf, mf_shiftf, [c38_rest, sys_places_and_newvalue, c38_environment, sys_env], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:[rest, environment], env:[sys_env], key:0, names:[sys_places_and_newvalue, sys_env], opt:0, req:0, rest:[sys_places_and_newvalue], sublists:0, whole:0}).
1799wl: init_args(0, mf_shiftf).
1800
1805sf_shiftf(Env_In, RestNKeys, FResult) :-
1806 mf_shiftf([shiftf|RestNKeys], Env_In, MFResult),
1807 f_sys_env_eval(Env_In, MFResult, FResult).
1812mf_shiftf([shiftf|RestNKeys], Env_In, MFResult) :-
1813 nop(defmacro),
1814 GEnv=[bv(sys_places_and_newvalue, RestNKeys), bv(sys_env, Env_In)],
1815 catch(( ( get_var(GEnv,
1816 sys_places_and_newvalue,
1817 Places_and_newvalue_Get),
1818 f_length(Places_and_newvalue_Get, Nargs_Init),
1819 BlockExitEnv=[bv(sys_nargs, Nargs_Init)|GEnv],
1820 catch(( call_addr_block(BlockExitEnv,
1821 (push_label(do_label_8), get_var(BlockExitEnv, sys_nargs, Nargs_Get25), (Nargs_Get25>=2->throw(block_exit([], [])), _TBResult=ThrowResult29;CAR=[], f_apply(sys_assert_places, [[], CAR, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [>=, sys_nargs, 2], []], Apply_Ret), setq_from_values(BlockExitEnv, []), goto(do_label_8, BlockExitEnv), _TBResult=_GORES31)),
1822
1823 [ addr(addr_tagbody_8_do_label_8,
1824 do_label_8,
1825 '$unused',
1826 BlockExitEnv,
1827 (get_var(BlockExitEnv, sys_nargs, Nargs_Get), (Nargs_Get>=2->throw(block_exit([], [])), _8250=ThrowResult;CAR63=[], f_apply(sys_assert_places, [[], CAR63, '$ARRAY'([*], claz_base_character, "The assertion ~:@(~S~) failed."), [>=, sys_nargs, 2], []], Apply_Ret62), setq_from_values(BlockExitEnv, []), goto(do_label_8, BlockExitEnv), _8250=_GORES)))
1828 ]),
1829 []=Block_exit_Ret
1830 ),
1831 block_exit([], Block_exit_Ret),
1832 true),
1833 get_var(BlockExitEnv,
1834 sys_places_and_newvalue,
1835 Places_and_newvalue_Get38),
1836 f_car(Places_and_newvalue_Get38, Place_Init),
1837 LEnv37=[bv(sys_place, Place_Init)|BlockExitEnv],
1838 LEnv42=[bv(sys_temps, []), bv(sys_vars, []), bv(sys_newvals, []), bv(sys_setter, []), bv(sys_getter, [])|LEnv37],
1839 get_var(LEnv42, sys_env, Env_Get),
1840 get_var(LEnv42, sys_place, Place_Get),
1841 f_get_setf_expansion(Place_Get, [Env_Get], Setf_expansion_Ret),
1842 setq_from_values(LEnv42,
1843
1844 [ sys_temps,
1845 sys_vars,
1846 sys_newvals,
1847 sys_setter,
1848 sys_getter
1849 ]),
1850 get_var(LEnv42, sys_temps, Temps_Get),
1851 get_var(LEnv42, sys_vars, Vars_Get),
1852 f_mapcar(f_list, [Temps_Get, Vars_Get], Mapcar_Ret),
1853 get_var(LEnv42, sys_getter, Getter_Get),
1854 get_var(LEnv42, sys_nargs, Nargs_Get50),
1855 get_var(LEnv42, sys_newvals, Newvals_Get),
1856 ( Nargs_Get50=:=2
1857 -> get_var(LEnv42,
1858 sys_places_and_newvalue,
1859 Places_and_newvalue_Get53),
1860 f_cadr(Places_and_newvalue_Get53, TrueResult55),
1861 CAR68=TrueResult55
1862 ; get_var(LEnv42,
1863 sys_places_and_newvalue,
1864 Places_and_newvalue_Get54),
1865 f_cdr(Places_and_newvalue_Get54, Cdr_Ret),
1866 CAR68=[shiftf|Cdr_Ret]
1867 ),
1868 get_var(LEnv42, sys_setter, Setter_Get)
1869 ),
1870 [let, Mapcar_Ret, [multiple_value_prog1, Getter_Get, [multiple_value_bind, Newvals_Get, CAR68, Setter_Get]]]=MFResult
1871 ),
1872 block_exit(shiftf, MFResult),
1873 true).
1874:- set_opv(mf_shiftf, type_of, sys_macro),
1875 set_opv(shiftf, symbol_function, mf_shiftf),
1876 DefMacroResult=shiftf. 1877/*
1878:- side_effect(assert_lsp(shiftf,
1879 lambda_def(defmacro,
1880 shiftf,
1881 mf_shiftf,
1882
1883 [ c38_rest,
1884 sys_places_and_newvalue,
1885 c38_environment,
1886 sys_env
1887 ],
1888
1889 [
1890 [ let,
1891
1892 [
1893 [ sys_nargs,
1894 [length, sys_places_and_newvalue]
1895 ]
1896 ],
1897 [assert, [>=, sys_nargs, 2]],
1898
1899 [ let,
1900
1901 [
1902 [ sys_place,
1903 [car, sys_places_and_newvalue]
1904 ]
1905 ],
1906
1907 [ multiple_value_bind,
1908
1909 [ sys_temps,
1910 sys_vars,
1911 sys_newvals,
1912 sys_setter,
1913 sys_getter
1914 ],
1915
1916 [ get_setf_expansion,
1917 sys_place,
1918 sys_env
1919 ],
1920
1921 [ '#BQ',
1922
1923 [ let,
1924
1925 [
1926 [ '#BQ-COMMA-ELIPSE',
1927
1928 [ mapcar,
1929 function(list),
1930 sys_temps,
1931 sys_vars
1932 ]
1933 ]
1934 ],
1935
1936 [ multiple_value_prog1,
1937 ['#COMMA', sys_getter],
1938
1939 [ multiple_value_bind,
1940 ['#COMMA', sys_newvals],
1941
1942 [ '#COMMA',
1943
1944 [ if,
1945 [=, sys_nargs, 2],
1946
1947 [ cadr,
1948 sys_places_and_newvalue
1949 ],
1950
1951 [ '#BQ',
1952
1953 [ shiftf,
1954
1955 [ '#BQ-COMMA-ELIPSE',
1956
1957 [ cdr,
1958 sys_places_and_newvalue
1959 ]
1960 ]
1961 ]
1962 ]
1963 ]
1964 ],
1965 ['#COMMA', sys_setter]
1966 ]
1967 ]
1968 ]
1969 ]
1970 ]
1971 ]
1972 ]
1973 ]))).
1974*/
1975/*
1976:- side_effect(assert_lsp(shiftf,
1977 arglist_info(shiftf,
1978 mf_shiftf,
1979
1980 [ c38_rest,
1981 sys_places_and_newvalue,
1982 c38_environment,
1983 sys_env
1984 ],
1985 arginfo{ all:0,
1986 allow_other_keys:0,
1987 aux:0,
1988 body:0,
1989 complex:[rest, environment],
1990 env:[sys_env],
1991 key:0,
1992 names:
1993 [ sys_places_and_newvalue,
1994 sys_env
1995 ],
1996 opt:0,
1997 req:0,
1998 rest:[sys_places_and_newvalue],
1999 sublists:0,
2000 whole:0
2001 }))).
2002*/
2003/*
2004:- side_effect(assert_lsp(shiftf, init_args(0, mf_shiftf))).
2005*/
2006/*
2007(defmacro rotatef (&rest places &environment env)
2008 (if (< (length places) 2)
2009 nil
2010 (multiple-value-bind (temps vars newvals setter getter)
2011 (get-setf-expansion (car places) env)
2012 `(let (,@(mapcar #'list temps vars))
2013 (multiple-value-bind ,newvals (shiftf ,@(cdr places) ,getter)
2014 ,setter)
2015 nil))))
2016
2017
2018;; Adapted from SBCL.
2019*/
2020
2021/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:6191 **********************/
2022:-lisp_compile_to_prolog(pkg_sys,[defmacro,rotatef,['&rest',places,'&environment',env],[if,[<,[length,places],2],[],['multiple-value-bind',[temps,vars,newvals,setter,getter],['get-setf-expansion',[car,places],env],['#BQ',[let,[['#BQ-COMMA-ELIPSE',[mapcar,function(list),temps,vars]]],['multiple-value-bind',['#COMMA',newvals],[shiftf,['#BQ-COMMA-ELIPSE',[cdr,places]],['#COMMA',getter]],['#COMMA',setter]],[]]]]]])
2023/*
2024:- side_effect(generate_function_or_macro_name(
2025 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
2026 name='GLOBAL',
2027 environ=env_1
2028 ],
2029 rotatef,
2030 kw_special,
2031 sf_rotatef)).
2032*/
2033wl:lambda_def(defmacro, rotatef, mf_rotatef, [c38_rest, sys_places, c38_environment, sys_env], [[if, [<, [length, sys_places], 2], [], [multiple_value_bind, [sys_temps, sys_vars, sys_newvals, sys_setter, sys_getter], [get_setf_expansion, [car, sys_places], sys_env], ['#BQ', [let, [['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_temps, sys_vars]]], [multiple_value_bind, ['#COMMA', sys_newvals], [shiftf, ['#BQ-COMMA-ELIPSE', [cdr, sys_places]], ['#COMMA', sys_getter]], ['#COMMA', sys_setter]], []]]]]]).
2034wl:arglist_info(rotatef, mf_rotatef, [c38_rest, sys_places, c38_environment, sys_env], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:[rest, environment], env:[sys_env], key:0, names:[sys_places, sys_env], opt:0, req:0, rest:[sys_places], sublists:0, whole:0}).
2035wl: init_args(0, mf_rotatef).
2036
2041sf_rotatef(Env_In, RestNKeys, FResult) :-
2042 mf_rotatef([rotatef|RestNKeys], Env_In, MFResult),
2043 f_sys_env_eval(Env_In, MFResult, FResult).
2048mf_rotatef([rotatef|RestNKeys], Env_In, MFResult) :-
2049 nop(defmacro),
2050 GEnv=[bv(sys_places, RestNKeys), bv(sys_env, Env_In)],
2051 catch(( ( get_var(GEnv, sys_places, Places_Get),
2052 f_length(Places_Get, PredArg1Result),
2053 ( PredArg1Result<2
2054 -> _7280=[]
2055 ; LEnv=[bv(sys_temps, []), bv(sys_vars, []), bv(sys_newvals, []), bv(sys_setter, []), bv(sys_getter, [])|GEnv],
2056 get_var(LEnv, sys_places, Places_Get13),
2057 f_car(Places_Get13, Setf_expansion_Param),
2058 get_var(LEnv, sys_env, Env_Get),
2059 f_get_setf_expansion(Setf_expansion_Param,
2060 [Env_Get],
2061 Setf_expansion_Ret),
2062 setq_from_values(LEnv,
2063
2064 [ sys_temps,
2065 sys_vars,
2066 sys_newvals,
2067 sys_setter,
2068 sys_getter
2069 ]),
2070 get_var(LEnv, sys_temps, Temps_Get),
2071 get_var(LEnv, sys_vars, Vars_Get),
2072 f_mapcar(f_list, [Temps_Get, Vars_Get], Mapcar_Ret),
2073 get_var(LEnv, sys_newvals, Newvals_Get),
2074 get_var(LEnv, sys_places, Places_Get18),
2075 f_cdr(Places_Get18, Cdr_Ret),
2076 get_var(LEnv, sys_getter, Getter_Get),
2077 bq_append([shiftf|Cdr_Ret], [Getter_Get], Bq_append_Ret),
2078 get_var(LEnv, sys_setter, Setter_Get),
2079 _7280=[let, Mapcar_Ret, [multiple_value_bind, Newvals_Get, Bq_append_Ret, Setter_Get], []]
2080 )
2081 ),
2082 _7280=MFResult
2083 ),
2084 block_exit(rotatef, MFResult),
2085 true).
2086:- set_opv(mf_rotatef, type_of, sys_macro),
2087 set_opv(rotatef, symbol_function, mf_rotatef),
2088 DefMacroResult=rotatef. 2089/*
2090:- side_effect(assert_lsp(rotatef,
2091 lambda_def(defmacro,
2092 rotatef,
2093 mf_rotatef,
2094
2095 [ c38_rest,
2096 sys_places,
2097 c38_environment,
2098 sys_env
2099 ],
2100
2101 [
2102 [ if,
2103 [<, [length, sys_places], 2],
2104 [],
2105
2106 [ multiple_value_bind,
2107
2108 [ sys_temps,
2109 sys_vars,
2110 sys_newvals,
2111 sys_setter,
2112 sys_getter
2113 ],
2114
2115 [ get_setf_expansion,
2116 [car, sys_places],
2117 sys_env
2118 ],
2119
2120 [ '#BQ',
2121
2122 [ let,
2123
2124 [
2125 [ '#BQ-COMMA-ELIPSE',
2126
2127 [ mapcar,
2128 function(list),
2129 sys_temps,
2130 sys_vars
2131 ]
2132 ]
2133 ],
2134
2135 [ multiple_value_bind,
2136 ['#COMMA', sys_newvals],
2137
2138 [ shiftf,
2139
2140 [ '#BQ-COMMA-ELIPSE',
2141 [cdr, sys_places]
2142 ],
2143 ['#COMMA', sys_getter]
2144 ],
2145 ['#COMMA', sys_setter]
2146 ],
2147 []
2148 ]
2149 ]
2150 ]
2151 ]
2152 ]))).
2153*/
2154/*
2155:- side_effect(assert_lsp(rotatef,
2156 arglist_info(rotatef,
2157 mf_rotatef,
2158
2159 [ c38_rest,
2160 sys_places,
2161 c38_environment,
2162 sys_env
2163 ],
2164 arginfo{ all:0,
2165 allow_other_keys:0,
2166 aux:0,
2167 body:0,
2168 complex:[rest, environment],
2169 env:[sys_env],
2170 key:0,
2171 names:[sys_places, sys_env],
2172 opt:0,
2173 req:0,
2174 rest:[sys_places],
2175 sublists:0,
2176 whole:0
2177 }))).
2178*/
2179/*
2180:- side_effect(assert_lsp(rotatef, init_args(0, mf_rotatef))).
2181*/
2182/*
2183; Adapted from SBCL.
2184*/
2185/*
2186(defmacro push (&environment env item place)
2187 (if (and (symbolp place)
2188 (eq place (macroexpand place env)))
2189 `(setq ,place (cons ,item ,place))
2190 (multiple-value-bind (dummies vals newval setter getter)
2191 (get-setf-expansion place env)
2192 (let ((g (gensym)))
2193 `(let* ((,g ,item)
2194 ,@(mapcar #'list dummies vals)
2195 (,(car newval) (cons ,g ,getter)))
2196 ,setter)))))
2197
2198;; Adapted from SBCL.
2199*/
2200
2201/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:6660 **********************/
2202:-lisp_compile_to_prolog(pkg_sys,[defmacro,push,['&environment',env,item,place],[if,[and,[symbolp,place],[eq,place,[macroexpand,place,env]]],['#BQ',[setq,['#COMMA',place],[cons,['#COMMA',item],['#COMMA',place]]]],['multiple-value-bind',[dummies,vals,newval,setter,getter],['get-setf-expansion',place,env],[let,[[g,[gensym]]],['#BQ',['let*',[[['#COMMA',g],['#COMMA',item]],['#BQ-COMMA-ELIPSE',[mapcar,function(list),dummies,vals]],[['#COMMA',[car,newval]],[cons,['#COMMA',g],['#COMMA',getter]]]],['#COMMA',setter]]]]]]])
2203/*
2204:- side_effect(generate_function_or_macro_name(
2205 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
2206 name='GLOBAL',
2207 environ=env_1
2208 ],
2209 push,
2210 kw_macro,
2211 mf_push)).
2212*/
2213wl:lambda_def(defmacro, push, mf_push, [c38_environment, sys_env, sys_item, sys_place], [[if, [and, [symbolp, sys_place], [eq, sys_place, [macroexpand, sys_place, sys_env]]], ['#BQ', [setq, ['#COMMA', sys_place], [cons, ['#COMMA', sys_item], ['#COMMA', sys_place]]]], [multiple_value_bind, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter], [get_setf_expansion, sys_place, sys_env], [let, [[sys_g, [gensym]]], ['#BQ', [let_xx, [[['#COMMA', sys_g], ['#COMMA', sys_item]], ['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_dummies, sys_vals]], [['#COMMA', [car, sys_newval]], [cons, ['#COMMA', sys_g], ['#COMMA', sys_getter]]]], ['#COMMA', sys_setter]]]]]]]).
2214wl:arglist_info(push, mf_push, [c38_environment, sys_env, sys_item, sys_place], arginfo{all:[sys_item, sys_place], allow_other_keys:0, aux:0, body:0, complex:[environment], env:[sys_env], key:0, names:[sys_env, sys_item, sys_place], opt:0, req:[sys_item, sys_place], rest:0, sublists:0, whole:0}).
2215wl: init_args(2, mf_push).
2216
2221sf_push(Env_In, Item_In, Place_In, RestNKeys, FResult) :-
2222 mf_push([push, Item_In, Place_In|RestNKeys], Env_In, MFResult),
2223 f_sys_env_eval(Env_In, MFResult, FResult).
2228mf_push([push, Item_In, Place_In|RestNKeys], Env_In, MFResult) :-
2229 nop(defmacro),
2230 GEnv=[bv(sys_env, Env_In), bv(sys_item, Item_In), bv(sys_place, Place_In)],
2231 catch(( ( get_var(GEnv, sys_place, Place_Get),
2232 ( is_symbolp(Place_Get)
2233 -> get_var(GEnv, sys_env, Env_Get),
2234 get_var(GEnv, sys_place, Place_Get13),
2235 f_macroexpand([Place_Get13, Env_Get], Macroexpand_Ret),
2236 f_eq(Place_Get13, Macroexpand_Ret, TrueResult),
2237 IFTEST=TrueResult
2238 ; IFTEST=[]
2239 ),
2240 ( IFTEST\==[]
2241 -> get_var(GEnv, sys_item, Item_Get),
2242 get_var(GEnv, sys_place, Place_Get17),
2243 _8750=[setq, Place_Get17, [cons, Item_Get, Place_Get17]]
2244 ; LEnv=[bv(sys_dummies, []), bv(sys_vals, []), bv(sys_newval, []), bv(sys_setter, []), bv(sys_getter, [])|GEnv],
2245 get_var(LEnv, sys_env, Env_Get24),
2246 get_var(LEnv, sys_place, Place_Get23),
2247 f_get_setf_expansion(Place_Get23,
2248 [Env_Get24],
2249 Setf_expansion_Ret),
2250 setq_from_values(LEnv,
2251
2252 [ sys_dummies,
2253 sys_vals,
2254 sys_newval,
2255 sys_setter,
2256 sys_getter
2257 ]),
2258 f_gensym(G_Init),
2259 LEnv27=[bv(sys_g, G_Init)|LEnv],
2260 get_var(LEnv27, sys_dummies, Dummies_Get),
2261 get_var(LEnv27, sys_g, G_Get),
2262 get_var(LEnv27, sys_item, Item_Get30),
2263 get_var(LEnv27, sys_vals, Vals_Get),
2264 f_mapcar(f_list, [Dummies_Get, Vals_Get], Mapcar_Ret),
2265 get_var(LEnv27, sys_newval, Newval_Get),
2266 f_car(Newval_Get, Car_Ret),
2267 get_var(LEnv27, sys_g, G_Get34),
2268 get_var(LEnv27, sys_getter, Getter_Get),
2269 bq_append([[G_Get, Item_Get30]|Mapcar_Ret],
2270 [[Car_Ret, [cons, G_Get34, Getter_Get]]],
2271 Bq_append_Ret),
2272 get_var(LEnv27, sys_setter, Setter_Get),
2273 _8750=[let_xx, Bq_append_Ret, Setter_Get]
2274 )
2275 ),
2276 _8750=MFResult
2277 ),
2278 block_exit(push, MFResult),
2279 true).
2280:- set_opv(mf_push, type_of, sys_macro),
2281 set_opv(push, symbol_function, mf_push),
2282 DefMacroResult=push. 2283/*
2284:- side_effect(assert_lsp(push,
2285 lambda_def(defmacro,
2286 push,
2287 mf_push,
2288
2289 [ c38_environment,
2290 sys_env,
2291 sys_item,
2292 sys_place
2293 ],
2294
2295 [
2296 [ if,
2297
2298 [ and,
2299 [symbolp, sys_place],
2300
2301 [ eq,
2302 sys_place,
2303 [macroexpand, sys_place, sys_env]
2304 ]
2305 ],
2306
2307 [ '#BQ',
2308
2309 [ setq,
2310 ['#COMMA', sys_place],
2311
2312 [ cons,
2313 ['#COMMA', sys_item],
2314 ['#COMMA', sys_place]
2315 ]
2316 ]
2317 ],
2318
2319 [ multiple_value_bind,
2320
2321 [ sys_dummies,
2322 sys_vals,
2323 sys_newval,
2324 sys_setter,
2325 sys_getter
2326 ],
2327
2328 [ get_setf_expansion,
2329 sys_place,
2330 sys_env
2331 ],
2332
2333 [ let,
2334 [[sys_g, [gensym]]],
2335
2336 [ '#BQ',
2337
2338 [ let_xx,
2339
2340 [
2341 [ ['#COMMA', sys_g],
2342 ['#COMMA', sys_item]
2343 ],
2344
2345 [ '#BQ-COMMA-ELIPSE',
2346
2347 [ mapcar,
2348 function(list),
2349 sys_dummies,
2350 sys_vals
2351 ]
2352 ],
2353
2354 [
2355 [ '#COMMA',
2356 [car, sys_newval]
2357 ],
2358
2359 [ cons,
2360 ['#COMMA', sys_g],
2361 ['#COMMA', sys_getter]
2362 ]
2363 ]
2364 ],
2365 ['#COMMA', sys_setter]
2366 ]
2367 ]
2368 ]
2369 ]
2370 ]
2371 ]))).
2372*/
2373/*
2374:- side_effect(assert_lsp(push,
2375 arglist_info(push,
2376 mf_push,
2377
2378 [ c38_environment,
2379 sys_env,
2380 sys_item,
2381 sys_place
2382 ],
2383 arginfo{ all:[sys_item, sys_place],
2384 allow_other_keys:0,
2385 aux:0,
2386 body:0,
2387 complex:[environment],
2388 env:[sys_env],
2389 key:0,
2390 names:
2391 [ sys_env,
2392 sys_item,
2393 sys_place
2394 ],
2395 opt:0,
2396 req:[sys_item, sys_place],
2397 rest:0,
2398 sublists:0,
2399 whole:0
2400 }))).
2401*/
2402/*
2403:- side_effect(assert_lsp(push, init_args(2, mf_push))).
2404*/
2405/*
2406; Adapted from SBCL.
2407*/
2408/*
2409(defmacro pushnew (&environment env item place &rest keys)
2410 (if (and (symbolp place)
2411 (eq place (macroexpand place env)))
2412 `(setq ,place (adjoin ,item ,place ,@keys))
2413 (multiple-value-bind (dummies vals newval setter getter)
2414 (get-setf-expansion place env)
2415 (let ((g (gensym)))
2416 `(let* ((,g ,item)
2417 ,@(mapcar #'list dummies vals)
2418 (,(car newval) (adjoin ,g ,getter ,@keys)))
2419 ,setter)))))
2420
2421;; Adapted from SBCL.
2422*/
2423
2424/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:7136 **********************/
2425:-lisp_compile_to_prolog(pkg_sys,[defmacro,pushnew,['&environment',env,item,place,'&rest',keys],[if,[and,[symbolp,place],[eq,place,[macroexpand,place,env]]],['#BQ',[setq,['#COMMA',place],[adjoin,['#COMMA',item],['#COMMA',place],['#BQ-COMMA-ELIPSE',keys]]]],['multiple-value-bind',[dummies,vals,newval,setter,getter],['get-setf-expansion',place,env],[let,[[g,[gensym]]],['#BQ',['let*',[[['#COMMA',g],['#COMMA',item]],['#BQ-COMMA-ELIPSE',[mapcar,function(list),dummies,vals]],[['#COMMA',[car,newval]],[adjoin,['#COMMA',g],['#COMMA',getter],['#BQ-COMMA-ELIPSE',keys]]]],['#COMMA',setter]]]]]]])
2426/*
2427:- side_effect(generate_function_or_macro_name(
2428 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
2429 name='GLOBAL',
2430 environ=env_1
2431 ],
2432 pushnew,
2433 kw_macro,
2434 mf_pushnew)).
2435*/
2436wl:lambda_def(defmacro, pushnew, mf_pushnew, [c38_environment, sys_env, sys_item, sys_place, c38_rest, sys_keys], [[if, [and, [symbolp, sys_place], [eq, sys_place, [macroexpand, sys_place, sys_env]]], ['#BQ', [setq, ['#COMMA', sys_place], [adjoin, ['#COMMA', sys_item], ['#COMMA', sys_place], ['#BQ-COMMA-ELIPSE', sys_keys]]]], [multiple_value_bind, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter], [get_setf_expansion, sys_place, sys_env], [let, [[sys_g, [gensym]]], ['#BQ', [let_xx, [[['#COMMA', sys_g], ['#COMMA', sys_item]], ['#BQ-COMMA-ELIPSE', [mapcar, function(list), sys_dummies, sys_vals]], [['#COMMA', [car, sys_newval]], [adjoin, ['#COMMA', sys_g], ['#COMMA', sys_getter], ['#BQ-COMMA-ELIPSE', sys_keys]]]], ['#COMMA', sys_setter]]]]]]]).
2437wl:arglist_info(pushnew, mf_pushnew, [c38_environment, sys_env, sys_item, sys_place, c38_rest, sys_keys], arginfo{all:[sys_item, sys_place], allow_other_keys:0, aux:0, body:0, complex:[environment, rest], env:[sys_env], key:0, names:[sys_env, sys_item, sys_place, sys_keys], opt:0, req:[sys_item, sys_place], rest:[sys_keys], sublists:0, whole:0}).
2438wl: init_args(2, mf_pushnew).
2439
2444sf_pushnew(Env_In, Item_In, Place_In, RestNKeys, FResult) :-
2445 mf_pushnew([pushnew, Item_In, Place_In|RestNKeys], Env_In, MFResult),
2446 f_sys_env_eval(Env_In, MFResult, FResult).
2451mf_pushnew([pushnew, Item_In, Place_In|RestNKeys], Env_In, MFResult) :-
2452 nop(defmacro),
2453 GEnv=[bv(sys_env, Env_In), bv(sys_item, Item_In), bv(sys_place, Place_In), bv(sys_keys, RestNKeys)],
2454 catch(( ( get_var(GEnv, sys_place, Place_Get),
2455 ( is_symbolp(Place_Get)
2456 -> get_var(GEnv, sys_env, Env_Get),
2457 get_var(GEnv, sys_place, Place_Get14),
2458 f_macroexpand([Place_Get14, Env_Get], Macroexpand_Ret),
2459 f_eq(Place_Get14, Macroexpand_Ret, TrueResult),
2460 IFTEST=TrueResult
2461 ; IFTEST=[]
2462 ),
2463 ( IFTEST\==[]
2464 -> get_var(GEnv, sys_item, Item_Get),
2465 ( get_var(GEnv, sys_keys, Keys_Get),
2466 get_var(GEnv, sys_place, Place_Get18)
2467 ),
2468 get_var(GEnv, sys_place, Place_Get20),
2469 _8976=[setq, Place_Get18, [adjoin, Item_Get, Place_Get20|Keys_Get]]
2470 ; LEnv=[bv(sys_dummies, []), bv(sys_vals, []), bv(sys_newval, []), bv(sys_setter, []), bv(sys_getter, [])|GEnv],
2471 get_var(LEnv, sys_env, Env_Get26),
2472 get_var(LEnv, sys_place, Place_Get25),
2473 f_get_setf_expansion(Place_Get25,
2474 [Env_Get26],
2475 Setf_expansion_Ret),
2476 setq_from_values(LEnv,
2477
2478 [ sys_dummies,
2479 sys_vals,
2480 sys_newval,
2481 sys_setter,
2482 sys_getter
2483 ]),
2484 f_gensym(G_Init),
2485 LEnv29=[bv(sys_g, G_Init)|LEnv],
2486 get_var(LEnv29, sys_dummies, Dummies_Get),
2487 get_var(LEnv29, sys_g, G_Get),
2488 get_var(LEnv29, sys_item, Item_Get32),
2489 get_var(LEnv29, sys_vals, Vals_Get),
2490 f_mapcar(f_list, [Dummies_Get, Vals_Get], Mapcar_Ret),
2491 get_var(LEnv29, sys_newval, Newval_Get),
2492 f_car(Newval_Get, Car_Ret),
2493 get_var(LEnv29, sys_g, G_Get36),
2494 get_var(LEnv29, sys_getter, Getter_Get),
2495 get_var(LEnv29, sys_keys, Keys_Get38),
2496 bq_append([[G_Get, Item_Get32]|Mapcar_Ret],
2497
2498 [
2499 [ Car_Ret,
2500 [adjoin, G_Get36, Getter_Get|Keys_Get38]
2501 ]
2502 ],
2503 Bq_append_Ret),
2504 get_var(LEnv29, sys_setter, Setter_Get),
2505 _8976=[let_xx, Bq_append_Ret, Setter_Get]
2506 )
2507 ),
2508 _8976=MFResult
2509 ),
2510 block_exit(pushnew, MFResult),
2511 true).
2512:- set_opv(mf_pushnew, type_of, sys_macro),
2513 set_opv(pushnew, symbol_function, mf_pushnew),
2514 DefMacroResult=pushnew. 2515/*
2516:- side_effect(assert_lsp(pushnew,
2517 lambda_def(defmacro,
2518 pushnew,
2519 mf_pushnew,
2520
2521 [ c38_environment,
2522 sys_env,
2523 sys_item,
2524 sys_place,
2525 c38_rest,
2526 sys_keys
2527 ],
2528
2529 [
2530 [ if,
2531
2532 [ and,
2533 [symbolp, sys_place],
2534
2535 [ eq,
2536 sys_place,
2537 [macroexpand, sys_place, sys_env]
2538 ]
2539 ],
2540
2541 [ '#BQ',
2542
2543 [ setq,
2544 ['#COMMA', sys_place],
2545
2546 [ adjoin,
2547 ['#COMMA', sys_item],
2548 ['#COMMA', sys_place],
2549 ['#BQ-COMMA-ELIPSE', sys_keys]
2550 ]
2551 ]
2552 ],
2553
2554 [ multiple_value_bind,
2555
2556 [ sys_dummies,
2557 sys_vals,
2558 sys_newval,
2559 sys_setter,
2560 sys_getter
2561 ],
2562
2563 [ get_setf_expansion,
2564 sys_place,
2565 sys_env
2566 ],
2567
2568 [ let,
2569 [[sys_g, [gensym]]],
2570
2571 [ '#BQ',
2572
2573 [ let_xx,
2574
2575 [
2576 [ ['#COMMA', sys_g],
2577 ['#COMMA', sys_item]
2578 ],
2579
2580 [ '#BQ-COMMA-ELIPSE',
2581
2582 [ mapcar,
2583 function(list),
2584 sys_dummies,
2585 sys_vals
2586 ]
2587 ],
2588
2589 [
2590 [ '#COMMA',
2591 [car, sys_newval]
2592 ],
2593
2594 [ adjoin,
2595 ['#COMMA', sys_g],
2596 ['#COMMA', sys_getter],
2597
2598 [ '#BQ-COMMA-ELIPSE',
2599 sys_keys
2600 ]
2601 ]
2602 ]
2603 ],
2604 ['#COMMA', sys_setter]
2605 ]
2606 ]
2607 ]
2608 ]
2609 ]
2610 ]))).
2611*/
2612/*
2613:- side_effect(assert_lsp(pushnew,
2614 arglist_info(pushnew,
2615 mf_pushnew,
2616
2617 [ c38_environment,
2618 sys_env,
2619 sys_item,
2620 sys_place,
2621 c38_rest,
2622 sys_keys
2623 ],
2624 arginfo{ all:[sys_item, sys_place],
2625 allow_other_keys:0,
2626 aux:0,
2627 body:0,
2628 complex:[environment, rest],
2629 env:[sys_env],
2630 key:0,
2631 names:
2632 [ sys_env,
2633 sys_item,
2634 sys_place,
2635 sys_keys
2636 ],
2637 opt:0,
2638 req:[sys_item, sys_place],
2639 rest:[sys_keys],
2640 sublists:0,
2641 whole:0
2642 }))).
2643*/
2644/*
2645:- side_effect(assert_lsp(pushnew, init_args(2, mf_pushnew))).
2646*/
2647/*
2648; Adapted from SBCL.
2649*/
2650/*
2651(defmacro pop (&environment env place)
2652 (if (and (symbolp place)
2653 (eq place (macroexpand place env)))
2654 `(prog1 (car ,place)
2655 (setq ,place (cdr ,place)))
2656 (multiple-value-bind (dummies vals newval setter getter)
2657 (get-setf-expansion place env)
2658 (do* ((d dummies (cdr d))
2659 (v vals (cdr v))
2660 (let-list nil))
2661 ((null d)
2662 (push (list (car newval) getter) let-list)
2663 `(let* ,(nreverse let-list)
2664 (prog1 (car ,(car newval))
2665 (setq ,(car newval) (cdr ,(car newval)))
2666 ,setter)))
2667 (push (list (car d) (car v)) let-list)))))
2668
2669
2670
2671*/
2672
2673/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/wam-cl-init-00.lisp:7644 **********************/
2674:-lisp_compile_to_prolog(pkg_sys,[defmacro,pop,['&environment',env,place],[if,[and,[symbolp,place],[eq,place,[macroexpand,place,env]]],['#BQ',[prog1,[car,['#COMMA',place]],[setq,['#COMMA',place],[cdr,['#COMMA',place]]]]],['multiple-value-bind',[dummies,vals,newval,setter,getter],['get-setf-expansion',place,env],['do*',[[d,dummies,[cdr,d]],[v,vals,[cdr,v]],['let-list',[]]],[[null,d],[push,[list,[car,newval],getter],'let-list'],['#BQ',['let*',['#COMMA',[nreverse,'let-list']],[prog1,[car,['#COMMA',[car,newval]]],[setq,['#COMMA',[car,newval]],[cdr,['#COMMA',[car,newval]]]],['#COMMA',setter]]]]],[push,[list,[car,d],[car,v]],'let-list']]]]])
2675/*
2676% macroexpand:-[push,[list,[car,sys_newval],sys_getter],sys_let_list].
2677*/
2678/*
2679% into:-[setq,sys_let_list,[cons,[list,[car,sys_newval],sys_getter],sys_let_list]].
2680*/
2681/*
2682% macroexpand:-[push,[list,[car,sys_d],[car,sys_v]],sys_let_list].
2683*/
2684/*
2685% into:-[setq,sys_let_list,[cons,[list,[car,sys_d],[car,sys_v]],sys_let_list]].
2686*/
2687/*
2688% macroexpand:-[push,[list,[car,sys_newval],sys_getter],sys_let_list].
2689*/
2690/*
2691% into:-[setq,sys_let_list,[cons,[list,[car,sys_newval],sys_getter],sys_let_list]].
2692*/
2693/*
2694% macroexpand:-[push,[list,[car,sys_d],[car,sys_v]],sys_let_list].
2695*/
2696/*
2697% into:-[setq,sys_let_list,[cons,[list,[car,sys_d],[car,sys_v]],sys_let_list]].
2698*/
2699/*
2700:- side_effect(generate_function_or_macro_name(
2701 [ fbound(sys_expand, kw_function)=function(f_sys_expand1),
2702 name='GLOBAL',
2703 environ=env_1
2704 ],
2705 pop,
2706 kw_special,
2707 sf_pop)).
2708*/
2709wl:lambda_def(defmacro, pop, mf_pop, [c38_environment, sys_env, sys_place], [[if, [and, [symbolp, sys_place], [eq, sys_place, [macroexpand, sys_place, sys_env]]], ['#BQ', [prog1, [car, ['#COMMA', sys_place]], [setq, ['#COMMA', sys_place], [cdr, ['#COMMA', sys_place]]]]], [multiple_value_bind, [sys_dummies, sys_vals, sys_newval, sys_setter, sys_getter], [get_setf_expansion, sys_place, sys_env], [do_xx, [[sys_d, sys_dummies, [cdr, sys_d]], [sys_v, sys_vals, [cdr, sys_v]], [sys_let_list, []]], [[null, sys_d], [push, [list, [car, sys_newval], sys_getter], sys_let_list], ['#BQ', [let_xx, ['#COMMA', [nreverse, sys_let_list]], [prog1, [car, ['#COMMA', [car, sys_newval]]], [setq, ['#COMMA', [car, sys_newval]], [cdr, ['#COMMA', [car, sys_newval]]]], ['#COMMA', sys_setter]]]]], [push, [list, [car, sys_d], [car, sys_v]], sys_let_list]]]]]).
2710wl:arglist_info(pop, mf_pop, [c38_environment, sys_env, sys_place], arginfo{all:[sys_place], allow_other_keys:0, aux:0, body:0, complex:[environment], env:[sys_env], key:0, names:[sys_env, sys_place], opt:0, req:[sys_place], rest:0, sublists:0, whole:0}).
2711wl: init_args(1, mf_pop).
2712
2717sf_pop(Env_In, Place_In, RestNKeys, FResult) :-
2718 mf_pop([pop, Place_In|RestNKeys], Env_In, MFResult),
2719 f_sys_env_eval(Env_In, MFResult, FResult).
2724mf_pop([pop, Place_In|RestNKeys], Env_In, MFResult) :-
2725 nop(defmacro),
2726 GEnv=[bv(sys_env, Env_In), bv(sys_place, Place_In)],
2727 catch(( ( get_var(GEnv, sys_place, Place_Get),
2728 ( is_symbolp(Place_Get)
2729 -> get_var(GEnv, sys_env, Env_Get),
2730 get_var(GEnv, sys_place, Place_Get12),
2731 f_macroexpand([Place_Get12, Env_Get], Macroexpand_Ret),
2732 f_eq(Place_Get12, Macroexpand_Ret, TrueResult),
2733 IFTEST=TrueResult
2734 ; IFTEST=[]
2735 ),
2736 ( IFTEST\==[]
2737 -> get_var(GEnv, sys_place, Place_Get16),
2738 _8118=[prog1, [car, Place_Get16], [setq, Place_Get16, [cdr, Place_Get16]]]
2739 ; LEnv=[bv(sys_dummies, []), bv(sys_vals, []), bv(sys_newval, []), bv(sys_setter, []), bv(sys_getter, [])|GEnv],
2740 get_var(LEnv, sys_env, Env_Get23),
2741 get_var(LEnv, sys_place, Place_Get22),
2742 f_get_setf_expansion(Place_Get22,
2743 [Env_Get23],
2744 Setf_expansion_Ret),
2745 setq_from_values(LEnv,
2746
2747 [ sys_dummies,
2748 sys_vals,
2749 sys_newval,
2750 sys_setter,
2751 sys_getter
2752 ]),
2753 get_var(LEnv, sys_dummies, Dummies_Get),
2754 LEnv26=[bv(sys_d, Dummies_Get)|LEnv],
2755 get_var(LEnv26, sys_vals, Vals_Get),
2756 LEnv31=[bv(sys_v, Vals_Get)|LEnv26],
2757 BlockExitEnv=[bv(sys_let_list, [])|LEnv31],
2758 catch(( call_addr_block(BlockExitEnv,
2759 (push_label(do_label_9), get_var(BlockExitEnv, sys_d, IFTEST63), (IFTEST63==[]->get_var(BlockExitEnv, sys_newval, Newval_Get69), f_car(Newval_Get69, Car_Ret), get_var(BlockExitEnv, sys_getter, Getter_Get70), CAR=[Car_Ret, Getter_Get70], get_var(BlockExitEnv, sys_let_list, Let_list_Get71), Let_list=[CAR|Let_list_Get71], set_var(BlockExitEnv, sys_let_list, Let_list), get_var(BlockExitEnv, sys_let_list, Let_list_Get72), f_nreverse(Let_list_Get72, Nreverse_Ret), get_var(BlockExitEnv, sys_newval, Newval_Get73), f_car(Newval_Get73, Car_Ret102), get_var(BlockExitEnv, sys_newval, Newval_Get74), f_car(Newval_Get74, Car_Ret103), get_var(BlockExitEnv, sys_newval, Newval_Get75), f_car(Newval_Get75, Car_Ret104), get_var(BlockExitEnv, sys_setter, Setter_Get76), throw(block_exit([], [let_xx, Nreverse_Ret, [prog1, [car, Car_Ret102], [setq, Car_Ret103, [cdr, Car_Ret104]], Setter_Get76]])), _TBResult=ThrowResult67;get_var(BlockExitEnv, sys_d, D_Get78), f_car(D_Get78, Car_Ret105), get_var(BlockExitEnv, sys_v, V_Get79), f_car(V_Get79, Car_Ret106), CAR107=[Car_Ret105, Car_Ret106], get_var(BlockExitEnv, sys_let_list, Let_list_Get80), Let_list92=[CAR107|Let_list_Get80], set_var(BlockExitEnv, sys_let_list, Let_list92), get_var(BlockExitEnv, sys_d, D_Get81), f_cdr(D_Get81, D), get_var(BlockExitEnv, sys_v, V_Get82), f_cdr(V_Get82, V), set_var(BlockExitEnv, sys_d, D), set_var(BlockExitEnv, sys_v, V), goto(do_label_9, BlockExitEnv), _TBResult=_GORES83)),
2760
2761 [ addr(addr_tagbody_9_do_label_9,
2762 do_label_9,
2763 '$unused',
2764 BlockExitEnv,
2765 (get_var(BlockExitEnv, sys_d, IFTEST38), (IFTEST38==[]->get_var(BlockExitEnv, sys_newval, Car_Param), f_car(Car_Param, Car_Ret108), get_var(BlockExitEnv, sys_getter, Get_var_Ret), CAR111=[Car_Ret108, Get_var_Ret], get_var(BlockExitEnv, sys_let_list, Get_var_Ret110), Set_var_Ret=[CAR111|Get_var_Ret110], set_var(BlockExitEnv, sys_let_list, Set_var_Ret), get_var(BlockExitEnv, sys_let_list, Let_list_Get47), f_nreverse(Let_list_Get47, Nreverse_Ret113), get_var(BlockExitEnv, sys_newval, Newval_Get48), f_car(Newval_Get48, Car_Ret114), get_var(BlockExitEnv, sys_newval, Newval_Get49), f_car(Newval_Get49, Car_Ret115), get_var(BlockExitEnv, sys_newval, Newval_Get50), f_car(Newval_Get50, Car_Ret116), get_var(BlockExitEnv, sys_setter, Get_var_Ret117), throw(block_exit([], [let_xx, Nreverse_Ret113, [prog1, [car, Car_Ret114], [setq, Car_Ret115, [cdr, Car_Ret116]], Get_var_Ret117]])), _10278=ThrowResult;get_var(BlockExitEnv, sys_d, D_Get53), f_car(D_Get53, Car_Ret118), get_var(BlockExitEnv, sys_v, Car_Param96), f_car(Car_Param96, Car_Ret119), CAR120=[Car_Ret118, Car_Ret119], get_var(BlockExitEnv, sys_let_list, Let_list_Get55), Set_var_Ret121=[CAR120|Let_list_Get55], set_var(BlockExitEnv, sys_let_list, Set_var_Ret121), get_var(BlockExitEnv, sys_d, D_Get56), f_cdr(D_Get56, Cdr_Ret), get_var(BlockExitEnv, sys_v, V_Get57), f_cdr(V_Get57, Cdr_Ret123), set_var(BlockExitEnv, sys_d, Cdr_Ret), set_var(BlockExitEnv, sys_v, Cdr_Ret123), goto(do_label_9, BlockExitEnv), _10278=_GORES)))
2766 ]),
2767 []=LetResult35
2768 ),
2769 block_exit([], LetResult35),
2770 true),
2771 _8118=LetResult35
2772 )
2773 ),
2774 _8118=MFResult
2775 ),
2776 block_exit(pop, MFResult),
2777 true).
2778:- set_opv(mf_pop, type_of, sys_macro),
2779 set_opv(pop, symbol_function, mf_pop),
2780 DefMacroResult=pop. 2912
2913