1#!/usr/bin/env swipl
6
7:-style_check(-discontiguous). 8:-style_check(-singleton). 9:-use_module(library(wamcl_runtime)). 10
11/*
12;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
13*/
14/*
15;;; Copyright (c) 1990, Giuseppe Attardi.
16*/
17/*
18;;;
19*/
20/*
21;;; This program is free software; you can redistribute it and/or
22*/
23/*
24;;; modify it under the terms of the GNU Library General Public
25*/
26/*
27;;; License as published by the Free Software Foundation; either
28*/
29/*
30;;; version 2 of the License, or (at your option) any later version.
31*/
32/*
33;;;
34*/
35/*
36;;; See file '../Copyright' for full details.
37*/
38/*
39;;; setf routines
40*/
41/*
42(in-package "SYSTEM")
43
44;;; DEFSETF macro.
45*/
46
47/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:494 **********************/
48:-lisp_compile_to_prolog(pkg_user,['in-package','$STRING'("SYSTEM")])
49/*
50% macroexpand:-[in_package,'$ARRAY'([*],claz_base_character,"SYSTEM")].
51*/
52/*
53% into:-[eval_when,[kw_compile_toplevel,kw_load_toplevel,kw_execute],[sys_select_package,'$ARRAY'([*],claz_base_character,"SYSTEM")]].
54*/
55:- do_when([kw_compile_toplevel, kw_load_toplevel, kw_execute],
56 f_sys_select_package('$ARRAY'([*], claz_base_character, "SYSTEM"),
57 _Ignored),
58 _Ignored).
59/*
60;; DEFSETF macro.
61*/
62/*
63(defmacro defsetf (access-fn &rest rest)
64 "Syntax: (defsetf symbol update-fun [doc])
65 or
66 (defsetf symbol lambda-list (store-var) {decl | doc}* {form}*)
67Defines an expansion
68 (setf (SYMBOL arg1 ... argn) value)
69 => (UPDATE-FUN arg1 ... argn value)
70 or
71 (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)
72where REST is the value of the last FORM with parameters in LAMBDA-LIST bound
73to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.
74The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved
75by (documentation 'SYMBOL 'setf)."
76 (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
77 `(eval-when (compile load eval)
78 (put-sysprop ',access-fn 'SETF-UPDATE-FN ',(car rest))
79 (rem-sysprop ',access-fn 'SETF-LAMBDA)
80 (rem-sysprop ',access-fn 'SETF-METHOD)
81 (rem-sysprop ',access-fn 'SETF-SYMBOL)
82 ,@(si::expand-set-documentation access-fn 'setf (cadr rest))
83 ',access-fn))
84 (t
85 (let* ((store (second rest))
86 (args (first rest))
87 (body (cddr rest))
88 (doc (find-documentation body)))
89 (unless (and (= (list-length store) 1) (symbolp (first store)))
90 (error "Single store-variable expected."))
91 (setq rest `(lambda ,args #'(lambda ,store ,@body)))
92 `(eval-when (compile load eval)
93 (put-sysprop ',access-fn 'SETF-LAMBDA #'(lambda (,@store ,@args) ,@body))
94 (rem-sysprop ',access-fn 'SETF-UPDATE-FN)
95 (rem-sysprop ',access-fn 'SETF-METHOD)
96 (rem-sysprop ',access-fn 'SETF-SYMBOL)
97 ,@(si::expand-set-documentation access-fn 'setf doc)
98 ',access-fn)))))
99
100
101;;; DEFINE-SETF-METHOD macro.
102*/
103
104/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:537 **********************/
105:-lisp_compile_to_prolog(pkg_sys,[defmacro,defsetf,['access-fn','&rest',rest],'$STRING'("Syntax: (defsetf symbol update-fun [doc])\n\tor\n\t(defsetf symbol lambda-list (store-var) {decl | doc}* {form}*)\nDefines an expansion\n\t(setf (SYMBOL arg1 ... argn) value)\n\t=> (UPDATE-FUN arg1 ... argn value)\n\t or\n\t (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)\nwhere REST is the value of the last FORM with parameters in LAMBDA-LIST bound\nto the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (documentation 'SYMBOL 'setf)."),[cond,[[and,[car,rest],[or,[symbolp,[car,rest]],[functionp,[car,rest]]]],['#BQ',['eval-when',[compile,load,eval],['put-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-UPDATE-FN'],[quote,['#COMMA',[car,rest]]]],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-LAMBDA']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-METHOD']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-SYMBOL']],['#BQ-COMMA-ELIPSE',['si::expand-set-documentation','access-fn',[quote,setf],[cadr,rest]]],[quote,['#COMMA','access-fn']]]]],[t,['let*',[[store,[second,rest]],[args,[first,rest]],[body,[cddr,rest]],[doc,['find-documentation',body]]],[unless,[and,[=,['list-length',store],1],[symbolp,[first,store]]],[error,'$STRING'("Single store-variable expected.")]],[setq,rest,['#BQ',[lambda,['#COMMA',args],function([lambda,['#COMMA',store],['#BQ-COMMA-ELIPSE',body]])]]],['#BQ',['eval-when',[compile,load,eval],['put-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-LAMBDA'],function([lambda,[['#BQ-COMMA-ELIPSE',store],['#BQ-COMMA-ELIPSE',args]],['#BQ-COMMA-ELIPSE',body]])],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-UPDATE-FN']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-METHOD']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-SYMBOL']],['#BQ-COMMA-ELIPSE',['si::expand-set-documentation','access-fn',[quote,setf],doc]],[quote,['#COMMA','access-fn']]]]]]]])
106/*
107:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
108 sys_expand_set_documentation,
109 kw_function,
110 f_sys_expand_set_documentation)).
111*/
112/*
113:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
114 sys_expand_set_documentation,
115 kw_function,
116 f_sys_expand_set_documentation)).
117*/
118/*
119:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
120 defsetf,
121 kw_special,
122 sf_defsetf)).
123*/
124doc: doc_string(defsetf,
125 _6576,
126 function,
127 "Syntax: (defsetf symbol update-fun [doc])\n\tor\n\t(defsetf symbol lambda-list (store-var) {decl | doc}* {form}*)\nDefines an expansion\n\t(setf (SYMBOL arg1 ... argn) value)\n\t=> (UPDATE-FUN arg1 ... argn value)\n\t or\n\t (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)\nwhere REST is the value of the last FORM with parameters in LAMBDA-LIST bound\nto the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (documentation 'SYMBOL 'setf).").
128
129wl:lambda_def(defmacro, defsetf, mf_defsetf, [sys_access_fn, c38_rest, rest], [[cond, [[and, [car, rest], [or, [symbolp, [car, rest]], [functionp, [car, rest]]]], ['#BQ', [eval_when, [compile, load, eval], [sys_put_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_update_fn], [quote, ['#COMMA', [car, rest]]]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_lambda]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_method]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_symbol]], ['#BQ-COMMA-ELIPSE', [sys_expand_set_documentation, sys_access_fn, [quote, setf], [cadr, rest]]], [quote, ['#COMMA', sys_access_fn]]]]], [t, [let_xx, [[sys_store, [second, rest]], [sys_args, [first, rest]], [sys_body, [cddr, rest]], [sys_doc, [sys_find_documentation, sys_body]]], [unless, [and, [=, [list_length, sys_store], 1], [symbolp, [first, sys_store]]], [error, '$ARRAY'([*], claz_base_character, "Single store-variable expected.")]], [setq, rest, ['#BQ', [lambda, ['#COMMA', sys_args], function([lambda, ['#COMMA', sys_store], ['#BQ-COMMA-ELIPSE', sys_body]])]]], ['#BQ', [eval_when, [compile, load, eval], [sys_put_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_lambda], function([lambda, [['#BQ-COMMA-ELIPSE', sys_store], ['#BQ-COMMA-ELIPSE', sys_args]], ['#BQ-COMMA-ELIPSE', sys_body]])], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_update_fn]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_method]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_symbol]], ['#BQ-COMMA-ELIPSE', [sys_expand_set_documentation, sys_access_fn, [quote, setf], sys_doc]], [quote, ['#COMMA', sys_access_fn]]]]]]]]).
130wl:arglist_info(defsetf, mf_defsetf, [sys_access_fn, c38_rest, rest], arginfo{all:[sys_access_fn], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_access_fn, rest], opt:0, req:[sys_access_fn], rest:[rest], sublists:0, whole:0}).
131wl: init_args(1, mf_defsetf).
132
137sf_defsetf(MacroEnv, Access_fn_In, RestNKeys, FResult) :-
138 mf_defsetf([defsetf, Access_fn_In|RestNKeys], MacroEnv, MFResult),
139 f_sys_env_eval(MacroEnv, MFResult, FResult).
144mf_defsetf([defsetf, Access_fn_In|RestNKeys], MacroEnv, MFResult) :-
145 nop(defmacro),
146 GEnv=[bv(sys_access_fn, Access_fn_In), bv(rest, RestNKeys)],
147 catch(( ( get_var(GEnv, rest, Rest_Get),
148 f_car(Rest_Get, IFTEST8),
149 ( IFTEST8\==[]
150 -> ( get_var(GEnv, rest, Rest_Get11),
151 f_car(Rest_Get11, Symbolp_Param),
152 f_symbolp(Symbolp_Param, FORM1_Res),
153 FORM1_Res\==[],
154 TrueResult=FORM1_Res
155 -> true
156 ; get_var(GEnv, rest, Rest_Get12),
157 f_car(Rest_Get12, Functionp_Param),
158 f_functionp(Functionp_Param, Functionp_Ret),
159 TrueResult=Functionp_Ret
160 ),
161 IFTEST=TrueResult
162 ; IFTEST=[]
163 ),
164 ( IFTEST\==[]
165 -> get_var(GEnv, rest, Rest_Get16),
166 get_var(GEnv, sys_access_fn, Access_fn_Get),
167 f_car(Rest_Get16, Car_Ret),
168 get_var(GEnv, rest, Rest_Get21),
169 get_var(GEnv, sys_access_fn, Access_fn_Get17),
170 f_cadr(Rest_Get21, Setf),
171 f_sys_expand_set_documentation(Access_fn_Get17,
172 setf,
173 Setf,
174 Set_documentation_Ret),
175 get_var(GEnv, sys_access_fn, Access_fn_Get22),
176 bq_append(
177 [
178 [ sys_rem_sysprop,
179 [quote, Access_fn_Get17],
180 [quote, sys_setf_symbol]
181 ]
182 | Set_documentation_Ret
183 ],
184 [[quote, Access_fn_Get22]],
185 Bq_append_Ret),
186 _6634=[eval_when, [compile, load, eval], [sys_put_sysprop, [quote, Access_fn_Get], [quote, sys_setf_update_fn], [quote, Car_Ret]], [sys_rem_sysprop, [quote, Access_fn_Get17], [quote, sys_setf_lambda]], [sys_rem_sysprop, [quote, Access_fn_Get17], [quote, sys_setf_method]]|Bq_append_Ret]
187 ; get_var(GEnv, rest, Rest_Get26),
188 f_second(Rest_Get26, Store_Init),
189 LEnv=[bv(sys_store, Store_Init)|GEnv],
190 get_var(LEnv, rest, Rest_Get31),
191 f_car(Rest_Get31, Args_Init),
192 LEnv30=[bv(sys_args, Args_Init)|LEnv],
193 get_var(LEnv30, rest, Rest_Get36),
194 f_cddr(Rest_Get36, Body_Init),
195 LEnv35=[bv(sys_body, Body_Init)|LEnv30],
196 get_var(LEnv35, sys_body, Body_Get),
197 f_sys_find_documentation(Body_Get, Doc_Init),
198 LEnv40=[bv(sys_doc, Doc_Init)|LEnv35],
199 get_var(LEnv40, sys_store, Store_Get),
200 f_list_length(Store_Get, PredArg1Result),
201 ( PredArg1Result=:=1
202 -> get_var(LEnv40, sys_store, Store_Get49),
203 f_car(Store_Get49, Symbolp_Param67),
204 f_symbolp(Symbolp_Param67, TrueResult50),
205 IFTEST43=TrueResult50
206 ; IFTEST43=[]
207 ),
208 ( IFTEST43\==[]
209 -> _7502=[]
210 ; f_error(
211 [ '$ARRAY'([*],
212 claz_base_character,
213 "Single store-variable expected.")
214 ],
215 ElseResult),
216 _7502=ElseResult
217 ),
218 get_var(LEnv40, sys_args, Args_Get),
219 set_var(LEnv40,
220 rest,
221
222 [ lambda,
223 Args_Get,
224 function(
225 [ lambda,
226 ['#COMMA', sys_store],
227 ['#BQ-COMMA-ELIPSE', sys_body]
228 ])
229 ]),
230 get_var(LEnv40, sys_access_fn, Access_fn_Get54),
231 get_var(LEnv40, sys_doc, Doc_Get),
232 f_sys_expand_set_documentation(Access_fn_Get54,
233 setf,
234 Doc_Get,
235 Set_documentation_Ret72),
236 get_var(LEnv40, sys_access_fn, Access_fn_Get60),
237 bq_append(
238 [
239 [ sys_rem_sysprop,
240 [quote, Access_fn_Get54],
241 [quote, sys_setf_symbol]
242 ]
243 | Set_documentation_Ret72
244 ],
245 [[quote, Access_fn_Get60]],
246 Bq_append_Ret73),
247 _6634=[eval_when, [compile, load, eval], [sys_put_sysprop, [quote, Access_fn_Get54], [quote, sys_setf_lambda], function([lambda, [['#BQ-COMMA-ELIPSE', sys_store], ['#BQ-COMMA-ELIPSE', sys_args]], ['#BQ-COMMA-ELIPSE', sys_body]])], [sys_rem_sysprop, [quote, Access_fn_Get54], [quote, sys_setf_update_fn]], [sys_rem_sysprop, [quote, Access_fn_Get54], [quote, sys_setf_method]]|Bq_append_Ret73]
248 )
249 ),
250 _6634=MFResult
251 ),
252 block_exit(defsetf, MFResult),
253 true).
254:- set_opv(mf_defsetf, type_of, sys_macro),
255 set_opv(defsetf, symbol_function, mf_defsetf),
256 DefMacroResult=defsetf. 257/*
258:- side_effect(assert_lsp(defsetf,
259 doc_string(defsetf,
260 _6576,
261 function,
262 "Syntax: (defsetf symbol update-fun [doc])\n\tor\n\t(defsetf symbol lambda-list (store-var) {decl | doc}* {form}*)\nDefines an expansion\n\t(setf (SYMBOL arg1 ... argn) value)\n\t=> (UPDATE-FUN arg1 ... argn value)\n\t or\n\t (let* ((temp1 ARG1) ... (tempn ARGn) (temp0 value)) rest)\nwhere REST is the value of the last FORM with parameters in LAMBDA-LIST bound\nto the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (documentation 'SYMBOL 'setf)."))).
263*/
264/*
265:- side_effect(assert_lsp(defsetf,
266 lambda_def(defmacro,
267 defsetf,
268 mf_defsetf,
269 [sys_access_fn, c38_rest, rest],
270
271 [
272 [ cond,
273
274 [
275 [ and,
276 [car, rest],
277
278 [ or,
279 [symbolp, [car, rest]],
280 [functionp, [car, rest]]
281 ]
282 ],
283
284 [ '#BQ',
285
286 [ eval_when,
287 [compile, load, eval],
288
289 [ sys_put_sysprop,
290
291 [ quote,
292 ['#COMMA', sys_access_fn]
293 ],
294 [quote, sys_setf_update_fn],
295 [quote, ['#COMMA', [car, rest]]]
296 ],
297
298 [ sys_rem_sysprop,
299
300 [ quote,
301 ['#COMMA', sys_access_fn]
302 ],
303 [quote, sys_setf_lambda]
304 ],
305
306 [ sys_rem_sysprop,
307
308 [ quote,
309 ['#COMMA', sys_access_fn]
310 ],
311 [quote, sys_setf_method]
312 ],
313
314 [ sys_rem_sysprop,
315
316 [ quote,
317 ['#COMMA', sys_access_fn]
318 ],
319 [quote, sys_setf_symbol]
320 ],
321
322 [ '#BQ-COMMA-ELIPSE',
323
324 [ sys_expand_set_documentation,
325 sys_access_fn,
326 [quote, setf],
327 [cadr, rest]
328 ]
329 ],
330
331 [ quote,
332 ['#COMMA', sys_access_fn]
333 ]
334 ]
335 ]
336 ],
337
338 [ t,
339
340 [ let_xx,
341
342 [ [sys_store, [second, rest]],
343 [sys_args, [first, rest]],
344 [sys_body, [cddr, rest]],
345
346 [ sys_doc,
347
348 [ sys_find_documentation,
349 sys_body
350 ]
351 ]
352 ],
353
354 [ unless,
355
356 [ and,
357 [=, [list_length, sys_store], 1],
358 [symbolp, [first, sys_store]]
359 ],
360
361 [ error,
362 '$ARRAY'([*],
363 claz_base_character,
364 "Single store-variable expected.")
365 ]
366 ],
367
368 [ setq,
369 rest,
370
371 [ '#BQ',
372
373 [ lambda,
374 ['#COMMA', sys_args],
375 function(
376 [ lambda,
377
378 [ '#COMMA',
379 sys_store
380 ],
381
382 [ '#BQ-COMMA-ELIPSE',
383 sys_body
384 ]
385 ])
386 ]
387 ]
388 ],
389
390 [ '#BQ',
391
392 [ eval_when,
393 [compile, load, eval],
394
395 [ sys_put_sysprop,
396
397 [ quote,
398 ['#COMMA', sys_access_fn]
399 ],
400 [quote, sys_setf_lambda],
401 function(
402 [ lambda,
403
404 [
405 [ '#BQ-COMMA-ELIPSE',
406 sys_store
407 ],
408
409 [ '#BQ-COMMA-ELIPSE',
410 sys_args
411 ]
412 ],
413
414 [ '#BQ-COMMA-ELIPSE',
415 sys_body
416 ]
417 ])
418 ],
419
420 [ sys_rem_sysprop,
421
422 [ quote,
423 ['#COMMA', sys_access_fn]
424 ],
425 [quote, sys_setf_update_fn]
426 ],
427
428 [ sys_rem_sysprop,
429
430 [ quote,
431 ['#COMMA', sys_access_fn]
432 ],
433 [quote, sys_setf_method]
434 ],
435
436 [ sys_rem_sysprop,
437
438 [ quote,
439 ['#COMMA', sys_access_fn]
440 ],
441 [quote, sys_setf_symbol]
442 ],
443
444 [ '#BQ-COMMA-ELIPSE',
445
446 [ sys_expand_set_documentation,
447 sys_access_fn,
448 [quote, setf],
449 sys_doc
450 ]
451 ],
452
453 [ quote,
454 ['#COMMA', sys_access_fn]
455 ]
456 ]
457 ]
458 ]
459 ]
460 ]
461 ]))).
462*/
463/*
464:- side_effect(assert_lsp(defsetf,
465 arglist_info(defsetf,
466 mf_defsetf,
467 [sys_access_fn, c38_rest, rest],
468 arginfo{ all:[sys_access_fn],
469 allow_other_keys:0,
470 aux:0,
471 body:0,
472 complex:[rest],
473 env:0,
474 key:0,
475 names:[sys_access_fn, rest],
476 opt:0,
477 req:[sys_access_fn],
478 rest:[rest],
479 sublists:0,
480 whole:0
481 }))).
482*/
483/*
484:- side_effect(assert_lsp(defsetf, init_args(1, mf_defsetf))).
485*/
486/*
487;; DEFINE-SETF-METHOD macro.
488*/
489/*
490(defmacro define-setf-expander (access-fn args &rest body)
491 "Syntax: (define-setf-expander symbol defmacro-lambda-list {decl | doc}*
492 {form}*)
493Defines the SETF-method for generalized-variables (SYMBOL ...).
494When a form (setf (SYMBOL arg1 ... argn) value-form) is evaluated, the FORMs
495given in the DEFINE-SETF-EXPANDER are evaluated in order with the parameters in
496DEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. The last FORM must return five
497values
498 (var1 ... vark)
499 (form1 ... formk)
500 (value-var)
501 storing-form
502 access-form
503in order. These values are collectively called the five gangs of the
504generalized variable (SYMBOL arg1 ... argn). The whole SETF form is then
505expanded into
506 (let* ((var1 from1) ... (vark formk)
507 (value-var value-form))
508 storing-form)
509The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved
510by (DOCUMENTATION 'SYMBOL 'SETF)."
511 (let ((env (member '&environment args :test #'eq)))
512 (if env
513 (setq args (cons (second env)
514 (nconc (ldiff args env) (cddr env))))
515 (progn
516 (setq env (gensym))
517 (setq args (cons env args))
518 (push `(declare (ignore ,env)) body))))
519 `(eval-when (compile load eval)
520 (put-sysprop ',access-fn 'SETF-METHOD #'(lambda ,args ,@body))
521 (rem-sysprop ',access-fn 'SETF-LAMBDA)
522 (rem-sysprop ',access-fn 'SETF-UPDATE-FN)
523 (rem-sysprop ',access-fn 'SETF-SYMBOL)
524 ,@(si::expand-set-documentation access-fn 'setf
525 (find-documentation body))
526 ',access-fn))
527
528
529;;; GET-SETF-METHOD.
530;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
531;;; and checks the number of the store variable.
532*/
533
534/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:2227 **********************/
535:-lisp_compile_to_prolog(pkg_sys,[defmacro,'define-setf-expander',['access-fn',args,'&rest',body],'$STRING'("Syntax: (define-setf-expander symbol defmacro-lambda-list {decl | doc}*\n {form}*)\nDefines the SETF-method for generalized-variables (SYMBOL ...).\nWhen a form (setf (SYMBOL arg1 ... argn) value-form) is evaluated, the FORMs\ngiven in the DEFINE-SETF-EXPANDER are evaluated in order with the parameters in\nDEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. The last FORM must return five\nvalues\n\t(var1 ... vark)\n\t(form1 ... formk)\n\t(value-var)\n\tstoring-form\n\taccess-form\nin order. These values are collectively called the five gangs of the\ngeneralized variable (SYMBOL arg1 ... argn). The whole SETF form is then\nexpanded into\n\t(let* ((var1 from1) ... (vark formk)\n\t (value-var value-form))\n\t storing-form)\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (DOCUMENTATION 'SYMBOL 'SETF)."),[let,[[env,[member,[quote,'&environment'],args,':test',function(eq)]]],[if,env,[setq,args,[cons,[second,env],[nconc,[ldiff,args,env],[cddr,env]]]],[progn,[setq,env,[gensym]],[setq,args,[cons,env,args]],[push,['#BQ',[declare,[ignore,['#COMMA',env]]]],body]]]],['#BQ',['eval-when',[compile,load,eval],['put-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-METHOD'],function([lambda,['#COMMA',args],['#BQ-COMMA-ELIPSE',body]])],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-LAMBDA']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-UPDATE-FN']],['rem-sysprop',[quote,['#COMMA','access-fn']],[quote,'SETF-SYMBOL']],['#BQ-COMMA-ELIPSE',['si::expand-set-documentation','access-fn',[quote,setf],['find-documentation',body]]],[quote,['#COMMA','access-fn']]]]])
536/*
537:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
538 sys_expand_set_documentation,
539 kw_function,
540 f_sys_expand_set_documentation)).
541*/
542/*
543:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
544 define_setf_expander,
545 kw_special,
546 sf_define_setf_expander)).
547*/
548doc: doc_string(define_setf_expander,
549 _5484,
550 function,
551 "Syntax: (define-setf-expander symbol defmacro-lambda-list {decl | doc}*\n {form}*)\nDefines the SETF-method for generalized-variables (SYMBOL ...).\nWhen a form (setf (SYMBOL arg1 ... argn) value-form) is evaluated, the FORMs\ngiven in the DEFINE-SETF-EXPANDER are evaluated in order with the parameters in\nDEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. The last FORM must return five\nvalues\n\t(var1 ... vark)\n\t(form1 ... formk)\n\t(value-var)\n\tstoring-form\n\taccess-form\nin order. These values are collectively called the five gangs of the\ngeneralized variable (SYMBOL arg1 ... argn). The whole SETF form is then\nexpanded into\n\t(let* ((var1 from1) ... (vark formk)\n\t (value-var value-form))\n\t storing-form)\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (DOCUMENTATION 'SYMBOL 'SETF).").
552
553wl:lambda_def(defmacro, define_setf_expander, mf_define_setf_expander, [sys_access_fn, sys_args, c38_rest, sys_body], [[let, [[sys_env, [member, [quote, c38_environment], sys_args, kw_test, function(eq)]]], [if, sys_env, [setq, sys_args, [cons, [second, sys_env], [nconc, [ldiff, sys_args, sys_env], [cddr, sys_env]]]], [progn, [setq, sys_env, [gensym]], [setq, sys_args, [cons, sys_env, sys_args]], [push, ['#BQ', [declare, [ignore, ['#COMMA', sys_env]]]], sys_body]]]], ['#BQ', [eval_when, [compile, load, eval], [sys_put_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_method], function([lambda, ['#COMMA', sys_args], ['#BQ-COMMA-ELIPSE', sys_body]])], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_lambda]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_update_fn]], [sys_rem_sysprop, [quote, ['#COMMA', sys_access_fn]], [quote, sys_setf_symbol]], ['#BQ-COMMA-ELIPSE', [sys_expand_set_documentation, sys_access_fn, [quote, setf], [sys_find_documentation, sys_body]]], [quote, ['#COMMA', sys_access_fn]]]]]).
554wl:arglist_info(define_setf_expander, mf_define_setf_expander, [sys_access_fn, sys_args, c38_rest, sys_body], arginfo{all:[sys_access_fn, sys_args], allow_other_keys:0, aux:0, body:0, complex:[rest], env:0, key:0, names:[sys_access_fn, sys_args, sys_body], opt:0, req:[sys_access_fn, sys_args], rest:[sys_body], sublists:0, whole:0}).
555wl: init_args(2, mf_define_setf_expander).
556
561sf_define_setf_expander(MacroEnv, Access_fn_In, Args_In, RestNKeys, FResult) :-
562 mf_define_setf_expander(
563 [ define_setf_expander,
564 Access_fn_In,
565 Args_In
566 | RestNKeys
567 ],
568 MacroEnv,
569 MFResult),
570 f_sys_env_eval(MacroEnv, MFResult, FResult).
575mf_define_setf_expander([define_setf_expander, Access_fn_In, Args_In|RestNKeys], MacroEnv, MFResult) :-
576 nop(defmacro),
577 GEnv=[bv(sys_access_fn, Access_fn_In), bv(sys_args, Args_In), bv(sys_body, RestNKeys)],
578 catch(( ( get_var(GEnv, sys_args, Args_Get),
579 f_member(c38_environment, Args_Get, [kw_test, f_eq], Env_Init),
580 LEnv=[bv(sys_env, Env_Init)|GEnv],
581 get_var(LEnv, sys_env, IFTEST),
582 ( IFTEST\==[]
583 -> get_var(LEnv, sys_env, Env_Get16),
584 f_second(Env_Get16, Second_Ret),
585 get_var(LEnv, sys_args, Args_Get17),
586 get_var(LEnv, sys_env, Env_Get18),
587 f_ldiff(Args_Get17, Env_Get18, Ldiff_Ret),
588 get_var(LEnv, sys_env, Env_Get19),
589 f_cddr(Env_Get19, Cddr_Ret),
590 f_nconc([Ldiff_Ret, Cddr_Ret], Nconc_Ret),
591 TrueResult=[Second_Ret|Nconc_Ret],
592 set_var(LEnv, sys_args, TrueResult),
593 LetResult=TrueResult
594 ; f_gensym([], Env),
595 set_var(LEnv, sys_env, Env),
596 get_var(LEnv, sys_args, Args_Get21),
597 get_var(LEnv, sys_env, Env_Get20),
598 Args=[Env_Get20|Args_Get21],
599 set_var(LEnv, sys_args, Args),
600 sf_push(LEnv,
601 ['#BQ', [declare, [ignore, ['#COMMA', sys_env]]]],
602 sys_body,
603 ElseResult),
604 LetResult=ElseResult
605 ),
606 get_var(GEnv, sys_access_fn, Access_fn_Get25),
607 get_var(GEnv, sys_body, Body_Get),
608 f_sys_find_documentation(Body_Get, Setf),
609 f_sys_expand_set_documentation(Access_fn_Get25,
610 setf,
611 Setf,
612 Set_documentation_Ret),
613 get_var(GEnv, sys_access_fn, Access_fn_Get30),
614 bq_append(
615 [
616 [ sys_rem_sysprop,
617 [quote, Access_fn_Get25],
618 [quote, sys_setf_symbol]
619 ]
620 | Set_documentation_Ret
621 ],
622 [[quote, Access_fn_Get30]],
623 Bq_append_Ret)
624 ),
625 [eval_when, [compile, load, eval], [sys_put_sysprop, [quote, Access_fn_Get25], [quote, sys_setf_method], function([lambda, ['#COMMA', sys_args], ['#BQ-COMMA-ELIPSE', sys_body]])], [sys_rem_sysprop, [quote, Access_fn_Get25], [quote, sys_setf_lambda]], [sys_rem_sysprop, [quote, Access_fn_Get25], [quote, sys_setf_update_fn]]|Bq_append_Ret]=MFResult
626 ),
627 block_exit(define_setf_expander, MFResult),
628 true).
629:- set_opv(mf_define_setf_expander, type_of, sys_macro),
630 set_opv(define_setf_expander, symbol_function, mf_define_setf_expander),
631 DefMacroResult=define_setf_expander. 632/*
633:- side_effect(assert_lsp(define_setf_expander,
634 doc_string(define_setf_expander,
635 _5484,
636 function,
637 "Syntax: (define-setf-expander symbol defmacro-lambda-list {decl | doc}*\n {form}*)\nDefines the SETF-method for generalized-variables (SYMBOL ...).\nWhen a form (setf (SYMBOL arg1 ... argn) value-form) is evaluated, the FORMs\ngiven in the DEFINE-SETF-EXPANDER are evaluated in order with the parameters in\nDEFMACRO-LAMBDA-LIST bound to ARG1 ... ARGn. The last FORM must return five\nvalues\n\t(var1 ... vark)\n\t(form1 ... formk)\n\t(value-var)\n\tstoring-form\n\taccess-form\nin order. These values are collectively called the five gangs of the\ngeneralized variable (SYMBOL arg1 ... argn). The whole SETF form is then\nexpanded into\n\t(let* ((var1 from1) ... (vark formk)\n\t (value-var value-form))\n\t storing-form)\nThe doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved\nby (DOCUMENTATION 'SYMBOL 'SETF)."))).
638*/
639/*
640:- side_effect(assert_lsp(define_setf_expander,
641 lambda_def(defmacro,
642 define_setf_expander,
643 mf_define_setf_expander,
644
645 [ sys_access_fn,
646 sys_args,
647 c38_rest,
648 sys_body
649 ],
650
651 [
652 [ let,
653
654 [
655 [ sys_env,
656
657 [ member,
658 [quote, c38_environment],
659 sys_args,
660 kw_test,
661 function(eq)
662 ]
663 ]
664 ],
665
666 [ if,
667 sys_env,
668
669 [ setq,
670 sys_args,
671
672 [ cons,
673 [second, sys_env],
674
675 [ nconc,
676 [ldiff, sys_args, sys_env],
677 [cddr, sys_env]
678 ]
679 ]
680 ],
681
682 [ progn,
683 [setq, sys_env, [gensym]],
684
685 [ setq,
686 sys_args,
687 [cons, sys_env, sys_args]
688 ],
689
690 [ push,
691
692 [ '#BQ',
693
694 [ declare,
695 [ignore, ['#COMMA', sys_env]]
696 ]
697 ],
698 sys_body
699 ]
700 ]
701 ]
702 ],
703
704 [ '#BQ',
705
706 [ eval_when,
707 [compile, load, eval],
708
709 [ sys_put_sysprop,
710 [quote, ['#COMMA', sys_access_fn]],
711 [quote, sys_setf_method],
712 function(
713 [ lambda,
714 ['#COMMA', sys_args],
715
716 [ '#BQ-COMMA-ELIPSE',
717 sys_body
718 ]
719 ])
720 ],
721
722 [ sys_rem_sysprop,
723 [quote, ['#COMMA', sys_access_fn]],
724 [quote, sys_setf_lambda]
725 ],
726
727 [ sys_rem_sysprop,
728 [quote, ['#COMMA', sys_access_fn]],
729 [quote, sys_setf_update_fn]
730 ],
731
732 [ sys_rem_sysprop,
733 [quote, ['#COMMA', sys_access_fn]],
734 [quote, sys_setf_symbol]
735 ],
736
737 [ '#BQ-COMMA-ELIPSE',
738
739 [ sys_expand_set_documentation,
740 sys_access_fn,
741 [quote, setf],
742
743 [ sys_find_documentation,
744 sys_body
745 ]
746 ]
747 ],
748 [quote, ['#COMMA', sys_access_fn]]
749 ]
750 ]
751 ]))).
752*/
753/*
754:- side_effect(assert_lsp(define_setf_expander,
755 arglist_info(define_setf_expander,
756 mf_define_setf_expander,
757
758 [ sys_access_fn,
759 sys_args,
760 c38_rest,
761 sys_body
762 ],
763 arginfo{ all:[sys_access_fn, sys_args],
764 allow_other_keys:0,
765 aux:0,
766 body:0,
767 complex:[rest],
768 env:0,
769 key:0,
770 names:
771 [ sys_access_fn,
772 sys_args,
773 sys_body
774 ],
775 opt:0,
776 req:[sys_access_fn, sys_args],
777 rest:[sys_body],
778 sublists:0,
779 whole:0
780 }))).
781*/
782/*
783:- side_effect(assert_lsp(define_setf_expander,
784 init_args(2, mf_define_setf_expander))).
785*/
786/*
787;; GET-SETF-METHOD.
788*/
789/*
790;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
791*/
792/*
793;; and checks the number of the store variable.
794*/
795/*
796(defun get-setf-expansion (form &optional env)
797 "Args: (place)
798Returns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.
799Checks if the third gang is a single-element list."
800 (multiple-value-bind (vars vals stores store-form access-form)
801 (get-setf-method-multiple-value form env)
802 (unless (= (list-length stores) 1)
803 (error "Multiple store-variables are not allowed."))
804 (values vars vals stores store-form access-form)))
805
806
807;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
808
809*/
810
811/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:3836 **********************/
812:-lisp_compile_to_prolog(pkg_sys,[defun,'get-setf-expansion',[form,'&optional',env],'$STRING'("Args: (place)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nChecks if the third gang is a single-element list."),['multiple-value-bind',[vars,vals,stores,'store-form','access-form'],['get-setf-method-multiple-value',form,env],[unless,[=,['list-length',stores],1],[error,'$STRING'("Multiple store-variables are not allowed.")]],[values,vars,vals,stores,'store-form','access-form']]])
813doc: doc_string(get_setf_expansion,
814 _3622,
815 function,
816 "Args: (place)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nChecks if the third gang is a single-element list.").
817
818wl:lambda_def(defun, get_setf_expansion, f_get_setf_expansion, [sys_form, c38_optional, sys_env], [[multiple_value_bind, [sys_vars, sys_vals, sys_stores, sys_store_form, sys_access_form], [sys_get_setf_method_multiple_value, sys_form, sys_env], [unless, [=, [list_length, sys_stores], 1], [error, '$ARRAY'([*], claz_base_character, "Multiple store-variables are not allowed.")]], [values, sys_vars, sys_vals, sys_stores, sys_store_form, sys_access_form]]]).
819wl:arglist_info(get_setf_expansion, f_get_setf_expansion, [sys_form, c38_optional, sys_env], arginfo{all:[sys_form, sys_env], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_form, sys_env], opt:[sys_env], req:[sys_form], rest:0, sublists:0, whole:0}).
820wl: init_args(1, f_get_setf_expansion).
821
826f_get_setf_expansion(Form_In, RestNKeys, FnResult) :-
827 CDR=[bv(sys_form, Form_In), bv(sys_env, Env_In)],
828 opt_var(Env, sys_env, Env_In, true, [], 1, RestNKeys),
829 catch(( ( LEnv=[bv(sys_vars, []), bv(sys_vals, []), bv(sys_stores, []), bv(sys_store_form, []), bv(sys_access_form, [])|CDR],
830 get_var(LEnv, sys_env, Env_Get),
831 get_var(LEnv, sys_form, Form_Get),
832 f_sys_get_setf_method_multiple_value(Form_Get,
833 [Env_Get],
834 Multiple_value_Ret),
835 setq_from_values(LEnv,
836
837 [ sys_vars,
838 sys_vals,
839 sys_stores,
840 sys_store_form,
841 sys_access_form
842 ]),
843 get_var(LEnv, sys_stores, Stores_Get),
844 f_list_length(Stores_Get, PredArg1Result),
845 ( PredArg1Result=:=1
846 -> _3808=[]
847 ; f_error(
848 [ '$ARRAY'([*],
849 claz_base_character,
850 "Multiple store-variables are not allowed.")
851 ],
852 ElseResult),
853 _3808=ElseResult
854 ),
855 get_var(LEnv, sys_access_form, Access_form_Get),
856 ( get_var(LEnv, sys_store_form, Store_form_Get),
857 get_var(LEnv, sys_stores, Stores_Get18)
858 ),
859 get_var(LEnv, sys_vals, Vals_Get),
860 nb_setval('$mv_return',
861
862 [ sys_vars,
863 Vals_Get,
864 Stores_Get18,
865 Store_form_Get,
866 Access_form_Get
867 ])
868 ),
869 sys_vars=FnResult
870 ),
871 block_exit(get_setf_expansion, FnResult),
872 true).
873:- set_opv(get_setf_expansion, symbol_function, f_get_setf_expansion),
874 DefunResult=get_setf_expansion. 875/*
876:- side_effect(assert_lsp(get_setf_expansion,
877 doc_string(get_setf_expansion,
878 _3622,
879 function,
880 "Args: (place)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nChecks if the third gang is a single-element list."))).
881*/
882/*
883:- side_effect(assert_lsp(get_setf_expansion,
884 lambda_def(defun,
885 get_setf_expansion,
886 f_get_setf_expansion,
887 [sys_form, c38_optional, sys_env],
888
889 [
890 [ multiple_value_bind,
891
892 [ sys_vars,
893 sys_vals,
894 sys_stores,
895 sys_store_form,
896 sys_access_form
897 ],
898
899 [ sys_get_setf_method_multiple_value,
900 sys_form,
901 sys_env
902 ],
903
904 [ unless,
905 [=, [list_length, sys_stores], 1],
906
907 [ error,
908 '$ARRAY'([*],
909 claz_base_character,
910 "Multiple store-variables are not allowed.")
911 ]
912 ],
913
914 [ values,
915 sys_vars,
916 sys_vals,
917 sys_stores,
918 sys_store_form,
919 sys_access_form
920 ]
921 ]
922 ]))).
923*/
924/*
925:- side_effect(assert_lsp(get_setf_expansion,
926 arglist_info(get_setf_expansion,
927 f_get_setf_expansion,
928 [sys_form, c38_optional, sys_env],
929 arginfo{ all:[sys_form, sys_env],
930 allow_other_keys:0,
931 aux:0,
932 body:0,
933 complex:0,
934 env:0,
935 key:0,
936 names:[sys_form, sys_env],
937 opt:[sys_env],
938 req:[sys_form],
939 rest:0,
940 sublists:0,
941 whole:0
942 }))).
943*/
944/*
945:- side_effect(assert_lsp(get_setf_expansion,
946 init_args(1, f_get_setf_expansion))).
947*/
948/*
949;;; GET-SETF-METHOD-MULTIPLE-VALUE.
950*/
951/*
952(defun get-setf-method-multiple-value (form &optional env &aux f)
953 "Args: (form)
954Returns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.
955Does not check if the third gang is a single-element list."
956 (flet ((rename-arguments (vars &aux names values all-args)
957 (dolist (item vars)
958 (unless (or (fixnump item) (keywordp item))
959 (push item values)
960 (setq item (gensym))
961 (push item names))
962 (push item all-args))
963 (values (gensym) (nreverse names) (nreverse values) (nreverse all-args))))
964 (cond ((and (setq f (macroexpand form env)) (not (equal f form)))
965 (return-from get-setf-method-multiple-value
966 (get-setf-method-multiple-value f env)))
967 ((symbolp form)
968 (let ((store (gensym)))
969 (values nil nil (list store) `(setq ,form ,store) form)))
970 ((or (not (consp form)) (not (symbolp (car form))))
971 (error "Cannot get the setf-method of "(defun get-setf-method-multiple-value (form &optional env &aux f)\n \"Args: (form)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nDoes not check if the third gang is a single-element list.\"\n (flet ((rename-arguments (vars &aux names values all-args)\n\t (dolist (item vars)\n\t (unless (or (fixnump item) (keywordp item))\n\t (push item values)\n\t (setq item (gensym))\n\t (push item names))\n\t (push item all-args))\n\t (values (gensym) (nreverse names) (nreverse values) (nreverse all-args))))\n (cond ((and (setq f (macroexpand form env)) (not (equal f form)))\n\t (return-from get-setf-method-multiple-value\n\t (get-setf-method-multiple-value f env)))\n\t ((symbolp form)\n\t (let ((store (gensym)))\n\t (values nil nil (list store) `(setq ,form ,store) form)))\n\t((or (not (consp form)) (not (symbolp (car form))))\n\t (error \"Cannot get the setf-method of ~S.\" form))\n\t ((setq f (get-sysprop (car form) 'SETF-METHOD))\n\t (apply f env (cdr form)))\n\t(t\n\t (let* ((name (car form)) writer)\n\t (multiple-value-bind (store vars inits all)\n\t\t (rename-arguments (cdr form))\n\t (setq writer\n\t\t (cond ((setq f (get-sysprop name 'SETF-UPDATE-FN))\n\t\t\t `(,f ,@all ,store))\n\t\t\t ((setq f (get-sysprop name 'STRUCTURE-ACCESS))\n\t\t\t (setf-structure-access (car all) (car f) (cdr f) store))\n\t\t\t ((setq f (get-sysprop (car form) 'SETF-LAMBDA))\n\t\t\t (apply f store all))\n\t\t\t (t\n\t\t\t `(funcall #'(SETF ,name) ,store ,@all))))\n\t (values vars inits (list store) writer (cons name all))))))))\n\n;;;; SETF definitions.\n\n".
972*/
973
974/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:4335 **********************/
975:-lisp_compile_to_prolog(pkg_sys,[defun,'get-setf-method-multiple-value',[form,'&optional',env,'&aux',f],'$STRING'("Args: (form)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nDoes not check if the third gang is a single-element list."),[flet,[['rename-arguments',[vars,'&aux',names,values,'all-args'],[dolist,[item,vars],[unless,[or,[fixnump,item],[keywordp,item]],[push,item,values],[setq,item,[gensym]],[push,item,names]],[push,item,'all-args']],[values,[gensym],[nreverse,names],[nreverse,values],[nreverse,'all-args']]]],[cond,[[and,[setq,f,[macroexpand,form,env]],[not,[equal,f,form]]],['return-from','get-setf-method-multiple-value',['get-setf-method-multiple-value',f,env]]],[[symbolp,form],[let,[[store,[gensym]]],[values,[],[],[list,store],['#BQ',[setq,['#COMMA',form],['#COMMA',store]]],form]]],[[or,[not,[consp,form]],[not,[symbolp,[car,form]]]],[error,'$STRING'("Cannot get the setf-method of ~S."),form]],[[setq,f,['get-sysprop',[car,form],[quote,'SETF-METHOD']]],[apply,f,env,[cdr,form]]],[t,['let*',[[name,[car,form]],writer],['multiple-value-bind',[store,vars,inits,all],['rename-arguments',[cdr,form]],[setq,writer,[cond,[[setq,f,['get-sysprop',name,[quote,'SETF-UPDATE-FN']]],['#BQ',[['#COMMA',f],['#BQ-COMMA-ELIPSE',all],['#COMMA',store]]]],[[setq,f,['get-sysprop',name,[quote,'STRUCTURE-ACCESS']]],['setf-structure-access',[car,all],[car,f],[cdr,f],store]],[[setq,f,['get-sysprop',[car,form],[quote,'SETF-LAMBDA']]],[apply,f,store,all]],[t,['#BQ',[funcall,function(['SETF',['#COMMA',name]]),['#COMMA',store],['#BQ-COMMA-ELIPSE',all]]]]]],[values,vars,inits,[list,store],writer,[cons,name,all]]]]]]]])
976/*
977:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
978 sys_rename_arguments,
979 kw_function,
980 f_sys_rename_arguments)).
981*/
982doc: doc_string(sys_get_setf_method_multiple_value,
983 _6760,
984 function,
985 "Args: (form)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nDoes not check if the third gang is a single-element list.").
986
987wl:lambda_def(defun, sys_get_setf_method_multiple_value, f_sys_get_setf_method_multiple_value, [sys_form, c38_optional, sys_env, c38_aux, sys_f], [[flet, [[sys_rename_arguments, [sys_vars, c38_aux, sys_names, values, sys_all_args], [dolist, [sys_item, sys_vars], [unless, [or, [sys_fixnump, sys_item], [keywordp, sys_item]], [push, sys_item, values], [setq, sys_item, [gensym]], [push, sys_item, sys_names]], [push, sys_item, sys_all_args]], [values, [gensym], [nreverse, sys_names], [nreverse, values], [nreverse, sys_all_args]]]], [cond, [[and, [setq, sys_f, [macroexpand, sys_form, sys_env]], [not, [equal, sys_f, sys_form]]], [return_from, sys_get_setf_method_multiple_value, [sys_get_setf_method_multiple_value, sys_f, sys_env]]], [[symbolp, sys_form], [let, [[sys_store, [gensym]]], [values, [], [], [list, sys_store], ['#BQ', [setq, ['#COMMA', sys_form], ['#COMMA', sys_store]]], sys_form]]], [[or, [not, [consp, sys_form]], [not, [symbolp, [car, sys_form]]]], [error, '$ARRAY'([*], claz_base_character, "Cannot get the setf-method of ~S."), sys_form]], [[setq, sys_f, [sys_get_sysprop, [car, sys_form], [quote, sys_setf_method]]], [apply, sys_f, sys_env, [cdr, sys_form]]], [t, [let_xx, [[sys_name, [car, sys_form]], sys_writer], [multiple_value_bind, [sys_store, sys_vars, sys_inits, sys_all], [sys_rename_arguments, [cdr, sys_form]], [setq, sys_writer, [cond, [[setq, sys_f, [sys_get_sysprop, sys_name, [quote, sys_setf_update_fn]]], ['#BQ', [['#COMMA', sys_f], ['#BQ-COMMA-ELIPSE', sys_all], ['#COMMA', sys_store]]]], [[setq, sys_f, [sys_get_sysprop, sys_name, [quote, sys_structure_access]]], [sys_setf_structure_access, [car, sys_all], [car, sys_f], [cdr, sys_f], sys_store]], [[setq, sys_f, [sys_get_sysprop, [car, sys_form], [quote, sys_setf_lambda]]], [apply, sys_f, sys_store, sys_all]], [t, ['#BQ', [funcall, function([setf, ['#COMMA', sys_name]]), ['#COMMA', sys_store], ['#BQ-COMMA-ELIPSE', sys_all]]]]]], [values, sys_vars, sys_inits, [list, sys_store], sys_writer, [cons, sys_name, sys_all]]]]]]]]).
988wl:arglist_info(sys_get_setf_method_multiple_value, f_sys_get_setf_method_multiple_value, [sys_form, c38_optional, sys_env, c38_aux, sys_f], arginfo{all:[sys_form, sys_env], allow_other_keys:0, aux:[sys_f], body:0, complex:0, env:0, key:0, names:[sys_form, sys_env, sys_f], opt:[sys_env], req:[sys_form], rest:0, sublists:0, whole:0}).
989wl: init_args(1, f_sys_get_setf_method_multiple_value).
990
995f_sys_get_setf_method_multiple_value(Form_In, RestNKeys, FnResult) :-
996 Env8=[bv(sys_form, Form_In), bv(sys_env, Env_In), bv(sys_f, In)],
997 opt_var(Env, sys_env, Env_In, true, [], 1, RestNKeys),
998 aux_var(Env, sys_f, In, true, []),
999 catch(( ( assert_lsp(sys_rename_arguments,
1000 wl:lambda_def(defun, sys_rename_arguments, f_sys_rename_arguments2, [sys_vars, c38_aux, sys_names, values, sys_all_args], [[dolist, [sys_item, sys_vars], [unless, [or, [sys_fixnump, sys_item], [keywordp, sys_item]], [push, sys_item, values], [setq, sys_item, [gensym]], [push, sys_item, sys_names]], [push, sys_item, sys_all_args]], [values, [gensym], [nreverse, sys_names], [nreverse, values], [nreverse, sys_all_args]]])),
1001 assert_lsp(sys_rename_arguments,
1002 wl:arglist_info(sys_rename_arguments, f_sys_rename_arguments2, [sys_vars, c38_aux, sys_names, values, sys_all_args], arginfo{all:[sys_vars], allow_other_keys:0, aux:[sys_names, values, sys_all_args], body:0, complex:0, env:0, key:0, names:[sys_vars, sys_names, values, sys_all_args], opt:0, req:[sys_vars], rest:0, sublists:0, whole:0})),
1003 assert_lsp(sys_rename_arguments,
1004 wl:init_args(1, f_sys_rename_arguments2)),
1005 assert_lsp(sys_rename_arguments,
1006 (f_sys_rename_arguments2(Vars_In, RestNKeys10, FnResult9):-GEnv=[bv(sys_vars, Vars_In), bv(sys_names, Names_In), bv(values, Values_In), bv(sys_all_args, All_args_In)], aux_var(Env8, sys_names, Names_In, true, []), aux_var(Env8, values, Values_In, true, []), aux_var(Env8, sys_all_args, All_args_In, true, []), catch(((get_var(GEnv, sys_vars, Vars_Get), BV=bv(sys_item, Ele), AEnv=[BV|GEnv], forall(member(Ele, Vars_Get), (nb_setarg(2, BV, Ele), (get_var(AEnv, sys_item, Item_Get), f_sys_fixnump(Item_Get, FORM1_Res), FORM1_Res\==[], IFTEST=FORM1_Res->true;get_var(AEnv, sys_item, Item_Get19), f_keywordp(Item_Get19, Keywordp_Ret), IFTEST=Keywordp_Ret), (IFTEST\==[]->_7030=[];sf_push(AEnv, sys_item, values, Values), f_gensym([], Item), set_var(AEnv, sys_item, Item), sf_push(AEnv, sys_item, sys_names, ElseResult), _7030=ElseResult), sf_push(AEnv, sys_item, sys_all_args, All_args))), f_gensym([], Gensym_Ret), get_var(GEnv, sys_names, Names_Get), f_nreverse(Names_Get, Nreverse_Ret), get_var(GEnv, values, Values_Get), f_nreverse(Values_Get, Nreverse_Ret136), get_var(GEnv, sys_all_args, All_args_Get), f_nreverse(All_args_Get, Nreverse_Ret137), nb_setval('$mv_return', [Gensym_Ret, Nreverse_Ret, Nreverse_Ret136, Nreverse_Ret137])), Gensym_Ret=FnResult9), block_exit(sys_rename_arguments, FnResult9), true))),
1007 get_var(
1008 [
1009 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1010 ]
1011 | Env8
1012 ],
1013 sys_env,
1014 Env_Get),
1015 get_var(
1016 [
1017 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1018 ]
1019 | Env8
1020 ],
1021 sys_form,
1022 Form_Get),
1023 f_macroexpand([Form_Get, Env_Get], IFTEST33),
1024 set_var(
1025 [
1026 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1027 ]
1028 | Env8
1029 ],
1030 sys_f,
1031 IFTEST33),
1032 ( IFTEST33\==[]
1033 -> get_var(
1034 [
1035 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1036 ]
1037 | Env8
1038 ],
1039 sys_f,
1040 Get),
1041 get_var(
1042 [
1043 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1044 ]
1045 | Env8
1046 ],
1047 sys_form,
1048 Form_Get38),
1049 f_equal(Get, Form_Get38, Not_Param),
1050 f_not(Not_Param, TrueResult),
1051 IFTEST31=TrueResult
1052 ; IFTEST31=[]
1053 ),
1054 ( IFTEST31\==[]
1055 -> get_var(
1056 [
1057 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1058 ]
1059 | Env8
1060 ],
1061 sys_env,
1062 Env_Get43),
1063 get_var(
1064 [
1065 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1066 ]
1067 | Env8
1068 ],
1069 sys_f,
1070 Get42),
1071 f_sys_get_setf_method_multiple_value(Get42,
1072 [Env_Get43],
1073 RetResult),
1074 throw(block_exit(sys_get_setf_method_multiple_value,
1075 RetResult)),
1076 _6868=ThrowResult
1077 ; get_var(
1078 [
1079 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1080 ]
1081 | Env8
1082 ],
1083 sys_form,
1084 Form_Get45),
1085 ( is_symbolp(Form_Get45)
1086 -> f_gensym([], Store_Init),
1087 LEnv=[bv(sys_store, Store_Init), fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)|Env8],
1088 get_var(LEnv, sys_store, Store_Get),
1089 CAR=[Store_Get],
1090 get_var(LEnv, sys_form, Form_Get53),
1091 get_var(LEnv, sys_store, Store_Get54),
1092 nb_setval('$mv_return',
1093
1094 [ [],
1095 [],
1096 CAR,
1097 [setq, Form_Get53, Store_Get54],
1098 Form_Get53
1099 ]),
1100 ElseResult117=[]
1101 ; ( get_var(
1102 [
1103 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1104 ]
1105 | Env8
1106 ],
1107 sys_form,
1108 Form_Get58),
1109 f_consp(Form_Get58, Not_Param126),
1110 f_not(Not_Param126, FORM1_Res60),
1111 FORM1_Res60\==[],
1112 IFTEST56=FORM1_Res60
1113 -> true
1114 ; get_var(
1115 [
1116 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1117 ]
1118 | Env8
1119 ],
1120 sys_form,
1121 Form_Get59),
1122 f_car(Form_Get59, Symbolp_Param),
1123 f_symbolp(Symbolp_Param, Not_Param128),
1124 f_not(Not_Param128, Not_Ret),
1125 IFTEST56=Not_Ret
1126 ),
1127 ( IFTEST56\==[]
1128 -> get_var(
1129 [
1130 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1131 ]
1132 | Env8
1133 ],
1134 sys_form,
1135 Form_Get61),
1136 f_error(
1137 [ '$ARRAY'([*],
1138 claz_base_character,
1139 "Cannot get the setf-method of ~S."),
1140 Form_Get61
1141 ],
1142 TrueResult113),
1143 ElseResult115=TrueResult113
1144 ; get_var(
1145 [
1146 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1147 ]
1148 | Env8
1149 ],
1150 sys_form,
1151 Form_Get64),
1152 f_car(Form_Get64, Get_sysprop_Param),
1153 f_sys_get_sysprop(Get_sysprop_Param,
1154 sys_setf_method,
1155 [],
1156 IFTEST62),
1157 set_var(
1158 [
1159 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1160 ]
1161 | Env8
1162 ],
1163 sys_f,
1164 IFTEST62),
1165 ( IFTEST62\==[]
1166 -> get_var(
1167 [
1168 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1169 ]
1170 | Env8
1171 ],
1172 sys_env,
1173 Env_Get66),
1174 get_var(
1175 [
1176 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1177 ]
1178 | Env8
1179 ],
1180 sys_f,
1181 Get65),
1182 get_var(
1183 [
1184 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1185 ]
1186 | Env8
1187 ],
1188 sys_form,
1189 Form_Get67),
1190 f_cdr(Form_Get67, Cdr_Ret),
1191 f_apply(Get65,
1192 [Env_Get66, Cdr_Ret],
1193 TrueResult112),
1194 ElseResult114=TrueResult112
1195 ; get_var(
1196 [
1197 [ fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)
1198 ]
1199 | Env8
1200 ],
1201 sys_form,
1202 Form_Get71),
1203 f_car(Form_Get71, Name_Init),
1204 LEnv70=[bv(sys_name, Name_Init), fbound(sys_rename_arguments, kw_function)=function(f_sys_rename_arguments2)|Env8],
1205 LEnv75=[bv(sys_writer, [])|LEnv70],
1206 LEnv78=[bv(sys_store, []), bv(sys_vars, []), bv(sys_inits, []), bv(sys_all, [])|LEnv75],
1207 get_var(LEnv78, sys_form, Form_Get79),
1208 f_cdr(Form_Get79, Rename_arguments2_Param),
1209 f_sys_rename_arguments2(Rename_arguments2_Param,
1210 [],
1211 Rename_arguments2_Ret),
1212 setq_from_values(LEnv78,
1213
1214 [ sys_store,
1215 sys_vars,
1216 sys_inits,
1217 sys_all
1218 ]),
1219 get_var(LEnv78, sys_name, Name_Get),
1220 f_sys_get_sysprop(Name_Get,
1221 sys_setf_update_fn,
1222 [],
1223 IFTEST81),
1224 set_var(LEnv78, sys_f, IFTEST81),
1225 ( IFTEST81\==[]
1226 -> get_var(LEnv78, sys_all, All_Get),
1227 get_var(LEnv78, sys_f, Get84),
1228 get_var(LEnv78, sys_store, Store_Get86),
1229 bq_append([Get84|All_Get],
1230 [Store_Get86],
1231 TrueResult105),
1232 Writer=TrueResult105
1233 ; get_var(LEnv78, sys_name, Name_Get89),
1234 f_sys_get_sysprop(Name_Get89,
1235 sys_structure_access,
1236 [],
1237 IFTEST87),
1238 set_var(LEnv78, sys_f, IFTEST87),
1239 ( IFTEST87\==[]
1240 -> get_var(LEnv78, sys_all, All_Get90),
1241 f_car(All_Get90,
1242 Structure_access_Param),
1243 get_var(LEnv78, sys_f, Get91),
1244 f_car(Get91, Car_Ret),
1245 get_var(LEnv78, sys_f, Get92),
1246 f_cdr(Get92, Cdr_Ret143),
1247 get_var(LEnv78,
1248 sys_store,
1249 Store_Get93),
1250 f_sys_setf_structure_access(Structure_access_Param,
1251 Car_Ret,
1252 Cdr_Ret143,
1253 Store_Get93,
1254 TrueResult103),
1255 ElseResult106=TrueResult103
1256 ; get_var(LEnv78, sys_form, Form_Get96),
1257 f_car(Form_Get96,
1258 Get_sysprop_Param132),
1259 f_sys_get_sysprop(Get_sysprop_Param132,
1260 sys_setf_lambda,
1261 [],
1262 IFTEST94),
1263 set_var(LEnv78, sys_f, IFTEST94),
1264 ( IFTEST94\==[]
1265 -> get_var(LEnv78,
1266 sys_all,
1267 All_Get99),
1268 get_var(LEnv78, sys_f, Get97),
1269 get_var(LEnv78,
1270 sys_store,
1271 Store_Get98),
1272 f_apply(Get97,
1273 [Store_Get98, All_Get99],
1274 TrueResult102),
1275 ElseResult104=TrueResult102
1276 ; get_var(LEnv78,
1277 sys_all,
1278 All_Get101),
1279 get_var(LEnv78,
1280 sys_store,
1281 Store_Get100),
1282 ElseResult104=[funcall, function([setf, ['#COMMA', sys_name]]), Store_Get100|All_Get101]
1283 ),
1284 ElseResult106=ElseResult104
1285 ),
1286 Writer=ElseResult106
1287 ),
1288 set_var(LEnv78, sys_writer, Writer),
1289 get_var(LEnv78, sys_inits, Inits_Get),
1290 get_var(LEnv78, sys_store, Store_Get108),
1291 CAR145=[Store_Get108],
1292 get_var(LEnv78, sys_all, All_Get111),
1293 get_var(LEnv78, sys_name, Name_Get110),
1294 get_var(LEnv78, sys_writer, Writer_Get),
1295 CAR144=[Name_Get110|All_Get111],
1296 nb_setval('$mv_return',
1297
1298 [ sys_vars,
1299 Inits_Get,
1300 CAR145,
1301 Writer_Get,
1302 CAR144
1303 ]),
1304 ElseResult114=sys_vars
1305 ),
1306 ElseResult115=ElseResult114
1307 ),
1308 ElseResult117=ElseResult115
1309 ),
1310 _6868=ElseResult117
1311 )
1312 ),
1313 _6868=FnResult
1314 ),
1315 block_exit(sys_get_setf_method_multiple_value, FnResult),
1316 true).
1317:- set_opv(sys_get_setf_method_multiple_value,
1318 symbol_function,
1319 f_sys_get_setf_method_multiple_value),
1320 DefunResult=sys_get_setf_method_multiple_value. 1321/*
1322:- side_effect(assert_lsp(sys_get_setf_method_multiple_value,
1323 doc_string(sys_get_setf_method_multiple_value,
1324 _6760,
1325 function,
1326 "Args: (form)\nReturns the 'five gangs' (see DEFINE-SETF-EXPANDER) for PLACE as five values.\nDoes not check if the third gang is a single-element list."))).
1327*/
1328/*
1329:- side_effect(assert_lsp(sys_get_setf_method_multiple_value,
1330 lambda_def(defun,
1331 sys_get_setf_method_multiple_value,
1332 f_sys_get_setf_method_multiple_value,
1333
1334 [ sys_form,
1335 c38_optional,
1336 sys_env,
1337 c38_aux,
1338 sys_f
1339 ],
1340
1341 [
1342 [ flet,
1343
1344 [
1345 [ sys_rename_arguments,
1346
1347 [ sys_vars,
1348 c38_aux,
1349 sys_names,
1350 values,
1351 sys_all_args
1352 ],
1353
1354 [ dolist,
1355 [sys_item, sys_vars],
1356
1357 [ unless,
1358
1359 [ or,
1360 [sys_fixnump, sys_item],
1361 [keywordp, sys_item]
1362 ],
1363 [push, sys_item, values],
1364 [setq, sys_item, [gensym]],
1365 [push, sys_item, sys_names]
1366 ],
1367 [push, sys_item, sys_all_args]
1368 ],
1369
1370 [ values,
1371 [gensym],
1372 [nreverse, sys_names],
1373 [nreverse, values],
1374 [nreverse, sys_all_args]
1375 ]
1376 ]
1377 ],
1378
1379 [ cond,
1380
1381 [
1382 [ and,
1383
1384 [ setq,
1385 sys_f,
1386
1387 [ macroexpand,
1388 sys_form,
1389 sys_env
1390 ]
1391 ],
1392 [not, [equal, sys_f, sys_form]]
1393 ],
1394
1395 [ return_from,
1396 sys_get_setf_method_multiple_value,
1397
1398 [ sys_get_setf_method_multiple_value,
1399 sys_f,
1400 sys_env
1401 ]
1402 ]
1403 ],
1404
1405 [ [symbolp, sys_form],
1406
1407 [ let,
1408 [[sys_store, [gensym]]],
1409
1410 [ values,
1411 [],
1412 [],
1413 [list, sys_store],
1414
1415 [ '#BQ',
1416
1417 [ setq,
1418 ['#COMMA', sys_form],
1419 ['#COMMA', sys_store]
1420 ]
1421 ],
1422 sys_form
1423 ]
1424 ]
1425 ],
1426
1427 [
1428 [ or,
1429 [not, [consp, sys_form]],
1430 [not, [symbolp, [car, sys_form]]]
1431 ],
1432
1433 [ error,
1434 '$ARRAY'([*],
1435 claz_base_character,
1436 "Cannot get the setf-method of ~S."),
1437 sys_form
1438 ]
1439 ],
1440
1441 [
1442 [ setq,
1443 sys_f,
1444
1445 [ sys_get_sysprop,
1446 [car, sys_form],
1447 [quote, sys_setf_method]
1448 ]
1449 ],
1450
1451 [ apply,
1452 sys_f,
1453 sys_env,
1454 [cdr, sys_form]
1455 ]
1456 ],
1457
1458 [ t,
1459
1460 [ let_xx,
1461
1462 [ [sys_name, [car, sys_form]],
1463 sys_writer
1464 ],
1465
1466 [ multiple_value_bind,
1467
1468 [ sys_store,
1469 sys_vars,
1470 sys_inits,
1471 sys_all
1472 ],
1473
1474 [ sys_rename_arguments,
1475 [cdr, sys_form]
1476 ],
1477
1478 [ setq,
1479 sys_writer,
1480
1481 [ cond,
1482
1483 [
1484 [ setq,
1485 sys_f,
1486
1487 [ sys_get_sysprop,
1488 sys_name,
1489
1490 [ quote,
1491 sys_setf_update_fn
1492 ]
1493 ]
1494 ],
1495
1496 [ '#BQ',
1497
1498 [ ['#COMMA', sys_f],
1499
1500 [ '#BQ-COMMA-ELIPSE',
1501 sys_all
1502 ],
1503
1504 [ '#COMMA',
1505 sys_store
1506 ]
1507 ]
1508 ]
1509 ],
1510
1511 [
1512 [ setq,
1513 sys_f,
1514
1515 [ sys_get_sysprop,
1516 sys_name,
1517
1518 [ quote,
1519 sys_structure_access
1520 ]
1521 ]
1522 ],
1523
1524 [ sys_setf_structure_access,
1525 [car, sys_all],
1526 [car, sys_f],
1527 [cdr, sys_f],
1528 sys_store
1529 ]
1530 ],
1531
1532 [
1533 [ setq,
1534 sys_f,
1535
1536 [ sys_get_sysprop,
1537 [car, sys_form],
1538
1539 [ quote,
1540 sys_setf_lambda
1541 ]
1542 ]
1543 ],
1544
1545 [ apply,
1546 sys_f,
1547 sys_store,
1548 sys_all
1549 ]
1550 ],
1551
1552 [ t,
1553
1554 [ '#BQ',
1555
1556 [ funcall,
1557 function(
1558 [ setf,
1559 ['#COMMA', sys_name]
1560 ]),
1561
1562 [ '#COMMA',
1563 sys_store
1564 ],
1565
1566 [ '#BQ-COMMA-ELIPSE',
1567 sys_all
1568 ]
1569 ]
1570 ]
1571 ]
1572 ]
1573 ],
1574
1575 [ values,
1576 sys_vars,
1577 sys_inits,
1578 [list, sys_store],
1579 sys_writer,
1580 [cons, sys_name, sys_all]
1581 ]
1582 ]
1583 ]
1584 ]
1585 ]
1586 ]
1587 ]))).
1588*/
1589/*
1590:- side_effect(assert_lsp(sys_get_setf_method_multiple_value,
1591 arglist_info(sys_get_setf_method_multiple_value,
1592 f_sys_get_setf_method_multiple_value,
1593
1594 [ sys_form,
1595 c38_optional,
1596 sys_env,
1597 c38_aux,
1598 sys_f
1599 ],
1600 arginfo{ all:[sys_form, sys_env],
1601 allow_other_keys:0,
1602 aux:[sys_f],
1603 body:0,
1604 complex:0,
1605 env:0,
1606 key:0,
1607 names:[sys_form, sys_env, sys_f],
1608 opt:[sys_env],
1609 req:[sys_form],
1610 rest:0,
1611 sublists:0,
1612 whole:0
1613 }))).
1614*/
1615/*
1616:- side_effect(assert_lsp(sys_get_setf_method_multiple_value,
1617 init_args(1, f_sys_get_setf_method_multiple_value))).
1618*/
1619/*
1620;;; SETF definitions.
1621*/
1622/*
1623(defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
1624*/
1625
1626/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/setf.lsp:5920 **********************/
1627:-lisp_compile_to_prolog(pkg_sys,[defsetf,car,[x],[y],['#BQ',[progn,[rplaca,['#COMMA',x],['#COMMA',y]],['#COMMA',y]]]])