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;;; The structure routines.
40*/
41/*
42(in-package "COMMON-LISP")
43*/
44
45/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:479 **********************/
46:-lisp_compile_to_prolog(pkg_user,['in-package','#:lisp'])
47/*
48% macroexpand:-[in_package,lisp1].
49*/
50/*
51% into:-[eval_when,[kw_compile_toplevel,kw_load_toplevel,kw_execute],[sys_select_package,'$ARRAY'([*],claz_base_character,"LISP")]].
52*/
53:- do_when([kw_compile_toplevel, kw_load_toplevel, kw_execute],
54 f_sys_select_package('$ARRAY'([*], claz_base_character, "LISP"),
55 _Ignored),
56 _Ignored).
57/*
58(export 'defstruct)
59
60*/
61
62/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:501 **********************/
63:-lisp_compile_to_prolog(pkg_cl,[export,[quote,defstruct]])
64:- f_export(defstruct, _Ignored).
65/*
66(in-package "SYSTEM")
67
68*/
69
70/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:522 **********************/
71:-lisp_compile_to_prolog(pkg_cl,['in-package','#:system'])
72/*
73% macroexpand:-[in_package,system1].
74*/
75/*
76% into:-[eval_when,[kw_compile_toplevel,kw_load_toplevel,kw_execute],[sys_select_package,'$ARRAY'([*],claz_base_character,"SYSTEM")]].
77*/
78:- do_when([kw_compile_toplevel, kw_load_toplevel, kw_execute],
79 f_sys_select_package('$ARRAY'([*], claz_base_character, "SYSTEM"),
80 _Ignored),
81 _Ignored).
82/*
83(proclaim '(optimize (safety 2) (space 3)))
84
85
86*/
87
88/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:545 **********************/
89:-lisp_compile_to_prolog(pkg_sys,[proclaim,[quote,[optimize,[safety,2],[space,3]]]])
90:- sf_proclaim(Sf_proclaim_Param,
91 [quote, [optimize, [safety, 2], [space, 3]]],
92 _Ignored).
93/*
94(defun make-access-function (name conc-name type named slot-descr)
95 (declare (ignore named))
96 (let* ((slot-name (nth 0 slot-descr))
97 ;; (default-init (nth 1 slot-descr))
98 ;; (slot-type (nth 2 slot-descr))
99 (read-only (nth 3 slot-descr))
100 (offset (nth 4 slot-descr))
101 (access-function (intern (string-concatenate (string conc-name)
102 (string slot-name)))))
103 (cond ((null type)
104 ;; If TYPE is NIL,
105 ;; the slot is at the offset in the structure-body.
106 (fset access-function #'(lambda (x)
107 (sys:structure-ref x name offset))))
108 ((or (eq type 'VECTOR)
109 (and (consp type)
110 (eq (car type) 'VECTOR)))
111 ;; If TYPE is VECTOR or (VECTOR ... ), ELT is used.
112 (fset access-function
113 #'(lambda (x) (elt x offset))))
114 ((eq type 'LIST)
115 ;; If TYPE is LIST, NTH is used.
116 (fset access-function
117 #'(lambda (x) (sys:list-nth offset x))))
118 (t (error ""(defun make-access-function (name conc-name type named slot-descr)\n (declare (ignore named))\n (let* ((slot-name (nth 0 slot-descr))\n\t ;; (default-init (nth 1 slot-descr))\n\t ;; (slot-type (nth 2 slot-descr))\n\t (read-only (nth 3 slot-descr))\n\t (offset (nth 4 slot-descr))\n\t (access-function (intern (string-concatenate (string conc-name)\n\t\t\t\t\t\t\t (string slot-name)))))\n (cond ((null type)\n ;; If TYPE is NIL,\n ;; the slot is at the offset in the structure-body.\n\t (fset access-function #'(lambda (x)\n\t\t\t\t (sys:structure-ref x name offset))))\n ((or (eq type 'VECTOR)\n (and (consp type)\n (eq (car type) 'VECTOR)))\n\t ;; If TYPE is VECTOR or (VECTOR ... ), ELT is used.\n (fset access-function\n\t\t #'(lambda (x) (elt x offset))))\n ((eq type 'LIST)\n ;; If TYPE is LIST, NTH is used.\n\t (fset access-function\n\t\t #'(lambda (x) (sys:list-nth offset x))))\n (t (error \"~S is an illegal structure type.\" type)))\n (if read-only\n\t(progn\n\t (rem-sysprop access-function 'SETF-UPDATE-FN)\n\t (rem-sysprop access-function 'SETF-LAMBDA)\n\t (rem-sysprop access-function 'SETF-DOCUMENTATION))\n\t(progn\n\t ;; The following is used by the compiler to expand inline ;; the accessor\n\t (put-sysprop-r access-function (cons (or type name) offset)\n\t\t 'STRUCTURE-ACCESS)))))\n \t\t \n\n".
119*/
120
121/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:591 **********************/
122:-lisp_compile_to_prolog(pkg_sys,[defun,'make-access-function',[name,'conc-name',type,named,'slot-descr'],[declare,[ignore,named]],['let*',[['slot-name',[nth,0,'slot-descr']],['read-only',[nth,3,'slot-descr']],[offset,[nth,4,'slot-descr']],['access-function',[intern,['string-concatenate',[string,'conc-name'],[string,'slot-name']]]]],[cond,[[null,type],[fset,'access-function',function([lambda,[x],['sys:structure-ref',x,name,offset]])]],[[or,[eq,type,[quote,'VECTOR']],[and,[consp,type],[eq,[car,type],[quote,'VECTOR']]]],[fset,'access-function',function([lambda,[x],[elt,x,offset]])]],[[eq,type,[quote,'LIST']],[fset,'access-function',function([lambda,[x],['sys:list-nth',offset,x]])]],[t,[error,'$STRING'("~S is an illegal structure type."),type]]],[if,'read-only',[progn,['rem-sysprop','access-function',[quote,'SETF-UPDATE-FN']],['rem-sysprop','access-function',[quote,'SETF-LAMBDA']],['rem-sysprop','access-function',[quote,'SETF-DOCUMENTATION']]],[progn,['put-sysprop-r','access-function',[cons,[or,type,name],offset],[quote,'STRUCTURE-ACCESS']]]]]])
123/*
124:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
125 sys_make_access_function,
126 kw_function,
127 f_sys_make_access_function)).
128*/
129/*
130:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
131 sys_string_concatenate,
132 kw_function,
133 f_sys_string_concatenate)).
134*/
135/*
136:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
137 sys_list_nth,
138 kw_function,
139 f_sys_list_nth)).
140*/
141/*
142:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
143 sys_rem_sysprop,
144 kw_function,
145 f_sys_rem_sysprop)).
146*/
147/*
148:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
149 sys_rem_sysprop,
150 kw_function,
151 f_sys_rem_sysprop)).
152*/
153/*
154:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
155 sys_rem_sysprop,
156 kw_function,
157 f_sys_rem_sysprop)).
158*/
159/*
160:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
161 sys_put_sysprop_r,
162 kw_function,
163 f_sys_put_sysprop_r)).
164*/
165wl:lambda_def(defun, sys_make_access_function, f_sys_make_access_function, [sys_name, sys_conc_name, type, sys_named, sys_slot_descr], [[declare, [ignore, sys_named]], [let_xx, [[sys_slot_name, [nth, 0, sys_slot_descr]], [sys_read_only, [nth, 3, sys_slot_descr]], [sys_offset, [nth, 4, sys_slot_descr]], [sys_access_function, [intern, [sys_string_concatenate, [string, sys_conc_name], [string, sys_slot_name]]]]], [cond, [[null, type], [sys_fset, sys_access_function, function([lambda, [sys_x], [sys_structure_ref, sys_x, sys_name, sys_offset]])]], [[or, [eq, type, [quote, vector]], [and, [consp, type], [eq, [car, type], [quote, vector]]]], [sys_fset, sys_access_function, function([lambda, [sys_x], [elt, sys_x, sys_offset]])]], [[eq, type, [quote, list]], [sys_fset, sys_access_function, function([lambda, [sys_x], [sys_list_nth, sys_offset, sys_x]])]], [t, [error, '$ARRAY'([*], claz_base_character, "~S is an illegal structure type."), type]]], [if, sys_read_only, [progn, [sys_rem_sysprop, sys_access_function, [quote, sys_setf_update_fn]], [sys_rem_sysprop, sys_access_function, [quote, sys_setf_lambda]], [sys_rem_sysprop, sys_access_function, [quote, sys_setf_documentation]]], [progn, [sys_put_sysprop_r, sys_access_function, [cons, [or, type, sys_name], sys_offset], [quote, sys_structure_access]]]]]]).
166wl:arglist_info(sys_make_access_function, f_sys_make_access_function, [sys_name, sys_conc_name, type, sys_named, sys_slot_descr], arginfo{all:[sys_name, sys_conc_name, type, sys_named, sys_slot_descr], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_name, sys_conc_name, type, sys_named, sys_slot_descr], opt:0, req:[sys_name, sys_conc_name, type, sys_named, sys_slot_descr], rest:0, sublists:0, whole:0}).
167wl: init_args(x, f_sys_make_access_function).
168
173f_sys_make_access_function(Name_In, Conc_name_In, Type_In, Named_In, Slot_descr_In, FnResult) :-
174 GEnv=[bv(sys_name, Name_In), bv(sys_conc_name, Conc_name_In), bv(type, Type_In), bv(sys_named, Named_In), bv(sys_slot_descr, Slot_descr_In)],
175 catch(( ( sf_declare(GEnv, [ignore, sys_named], Sf_declare_Ret),
176 get_var(GEnv, sys_slot_descr, Slot_descr_Get),
177 f_nth(0, Slot_descr_Get, Slot_name_Init),
178 LEnv=[bv(sys_slot_name, Slot_name_Init)|GEnv],
179 get_var(LEnv, sys_slot_descr, Slot_descr_Get17),
180 f_nth(3, Slot_descr_Get17, Read_only_Init),
181 LEnv16=[bv(sys_read_only, Read_only_Init)|LEnv],
182 get_var(LEnv16, sys_slot_descr, Slot_descr_Get22),
183 f_nth(4, Slot_descr_Get22, Offset_Init),
184 LEnv21=[bv(sys_offset, Offset_Init)|LEnv16],
185 get_var(LEnv21, sys_conc_name, Conc_name_Get),
186 f_string(Conc_name_Get, String_concatenate_Param),
187 get_var(LEnv21, sys_slot_name, Slot_name_Get),
188 f_string(Slot_name_Get, String_Ret),
189 f_sys_string_concatenate(String_concatenate_Param,
190 String_Ret,
191 Intern_Param),
192 f_intern(Intern_Param, Access_function_Init),
193 LEnv26=[bv(sys_access_function, Access_function_Init)|LEnv21],
194 get_var(LEnv26, type, IFTEST),
195 ( IFTEST==[]
196 -> get_var(LEnv26, sys_access_function, Access_function_Get),
197 f_sys_fset(Access_function_Get,
198 closure(kw_function,
199 [ClosureEnvironment|LEnv26],
200 Whole,
201 LResult,
202 [sys_x],
203 (get_var(ClosureEnvironment, sys_name, Name_Get), get_var(ClosureEnvironment, sys_offset, Offset_Get), get_var(ClosureEnvironment, sys_x, X_Get), f_sys_structure_ref(X_Get, Name_Get, Offset_Get, LResult)),
204
205 [ lambda,
206 [sys_x],
207
208 [ sys_structure_ref,
209 sys_x,
210 sys_name,
211 sys_offset
212 ]
213 ]),
214 TrueResult74),
215 _8224=TrueResult74
216 ; ( get_var(LEnv26, type, Type_Get43),
217 f_eq(Type_Get43, vector, FORM1_Res),
218 FORM1_Res\==[],
219 IFTEST41=FORM1_Res
220 -> true
221 ; get_var(LEnv26, type, Type_Get45),
222 ( c0nz:is_consp(Type_Get45)
223 -> get_var(LEnv26, type, Type_Get48),
224 f_car(Type_Get48, Eq_Param),
225 f_eq(Eq_Param, vector, TrueResult),
226 _8562=TrueResult
227 ; _8562=[]
228 ),
229 IFTEST41=_8562
230 ),
231 ( IFTEST41\==[]
232 -> get_var(LEnv26,
233 sys_access_function,
234 Access_function_Get51),
235 f_sys_fset(Access_function_Get51,
236 closure(kw_function,
237 [ClosureEnvironment56|LEnv26],
238 Whole57,
239 LResult54,
240 [sys_x],
241 (get_var(ClosureEnvironment56, sys_offset, Offset_Get53), get_var(ClosureEnvironment56, sys_x, X_Get52), f_elt(X_Get52, Offset_Get53, LResult54)),
242
243 [ lambda,
244 [sys_x],
245 [elt, sys_x, sys_offset]
246 ]),
247 TrueResult72),
248 ElseResult75=TrueResult72
249 ; get_var(LEnv26, type, Type_Get59),
250 ( is_eq(Type_Get59, list)
251 -> get_var(LEnv26,
252 sys_access_function,
253 Access_function_Get62),
254 f_sys_fset(Access_function_Get62,
255 closure(kw_function,
256 [ClosureEnvironment67|LEnv26],
257 Whole68,
258 LResult65,
259 [sys_x],
260 (get_var(ClosureEnvironment67, sys_offset, Offset_Get63), get_var(ClosureEnvironment67, sys_x, X_Get64), f_sys_list_nth(Offset_Get63, X_Get64, LResult65)),
261
262 [ lambda,
263 [sys_x],
264
265 [ sys_list_nth,
266 sys_offset,
267 sys_x
268 ]
269 ]),
270 TrueResult70),
271 ElseResult73=TrueResult70
272 ; get_var(LEnv26, type, Type_Get69),
273 f_error(
274 [ '$ARRAY'([*],
275 claz_base_character,
276 "~S is an illegal structure type."),
277 Type_Get69
278 ],
279 ElseResult),
280 ElseResult73=ElseResult
281 ),
282 ElseResult75=ElseResult73
283 ),
284 _8224=ElseResult75
285 ),
286 get_var(LEnv26, sys_read_only, IFTEST76),
287 ( IFTEST76\==[]
288 -> get_var(LEnv26,
289 sys_access_function,
290 Access_function_Get79),
291 f_sys_rem_sysprop(Access_function_Get79,
292 sys_setf_update_fn,
293 Setf_update_fn),
294 get_var(LEnv26,
295 sys_access_function,
296 Access_function_Get80),
297 f_sys_rem_sysprop(Access_function_Get80,
298 sys_setf_lambda,
299 Setf_lambda),
300 get_var(LEnv26,
301 sys_access_function,
302 Access_function_Get81),
303 f_sys_rem_sysprop(Access_function_Get81,
304 sys_setf_documentation,
305 TrueResult87),
306 LetResult15=TrueResult87
307 ; get_var(LEnv26,
308 sys_access_function,
309 Access_function_Get82),
310 ( get_var(LEnv26, type, Type_Get83),
311 Type_Get83\==[],
312 CAR=Type_Get83
313 -> true
314 ; get_var(LEnv26, sys_name, Name_Get84),
315 CAR=Name_Get84
316 ),
317 get_var(LEnv26, sys_offset, Offset_Get86),
318 _9650=[CAR|Offset_Get86],
319 f_sys_put_sysprop_r(Access_function_Get82,
320 _9650,
321 sys_structure_access,
322 ElseResult88),
323 LetResult15=ElseResult88
324 )
325 ),
326 LetResult15=FnResult
327 ),
328 block_exit(sys_make_access_function, FnResult),
329 true).
330:- set_opv(sys_make_access_function,
331 symbol_function,
332 f_sys_make_access_function),
333 DefunResult=sys_make_access_function. 334/*
335:- side_effect(assert_lsp(sys_make_access_function,
336 lambda_def(defun,
337 sys_make_access_function,
338 f_sys_make_access_function,
339
340 [ sys_name,
341 sys_conc_name,
342 type,
343 sys_named,
344 sys_slot_descr
345 ],
346
347 [ [declare, [ignore, sys_named]],
348
349 [ let_xx,
350
351 [
352 [ sys_slot_name,
353 [nth, 0, sys_slot_descr]
354 ],
355
356 [ sys_read_only,
357 [nth, 3, sys_slot_descr]
358 ],
359 [sys_offset, [nth, 4, sys_slot_descr]],
360
361 [ sys_access_function,
362
363 [ intern,
364
365 [ sys_string_concatenate,
366 [string, sys_conc_name],
367 [string, sys_slot_name]
368 ]
369 ]
370 ]
371 ],
372
373 [ cond,
374
375 [ [null, type],
376
377 [ sys_fset,
378 sys_access_function,
379 function(
380 [ lambda,
381 [sys_x],
382
383 [ sys_structure_ref,
384 sys_x,
385 sys_name,
386 sys_offset
387 ]
388 ])
389 ]
390 ],
391
392 [
393 [ or,
394 [eq, type, [quote, vector]],
395
396 [ and,
397 [consp, type],
398
399 [ eq,
400 [car, type],
401 [quote, vector]
402 ]
403 ]
404 ],
405
406 [ sys_fset,
407 sys_access_function,
408 function(
409 [ lambda,
410 [sys_x],
411
412 [ elt,
413 sys_x,
414 sys_offset
415 ]
416 ])
417 ]
418 ],
419
420 [ [eq, type, [quote, list]],
421
422 [ sys_fset,
423 sys_access_function,
424 function(
425 [ lambda,
426 [sys_x],
427
428 [ sys_list_nth,
429 sys_offset,
430 sys_x
431 ]
432 ])
433 ]
434 ],
435
436 [ t,
437
438 [ error,
439 '$ARRAY'([*],
440 claz_base_character,
441 "~S is an illegal structure type."),
442 type
443 ]
444 ]
445 ],
446
447 [ if,
448 sys_read_only,
449
450 [ progn,
451
452 [ sys_rem_sysprop,
453 sys_access_function,
454 [quote, sys_setf_update_fn]
455 ],
456
457 [ sys_rem_sysprop,
458 sys_access_function,
459 [quote, sys_setf_lambda]
460 ],
461
462 [ sys_rem_sysprop,
463 sys_access_function,
464 [quote, sys_setf_documentation]
465 ]
466 ],
467
468 [ progn,
469
470 [ sys_put_sysprop_r,
471 sys_access_function,
472
473 [ cons,
474 [or, type, sys_name],
475 sys_offset
476 ],
477 [quote, sys_structure_access]
478 ]
479 ]
480 ]
481 ]
482 ]))).
483*/
484/*
485:- side_effect(assert_lsp(sys_make_access_function,
486 arglist_info(sys_make_access_function,
487 f_sys_make_access_function,
488
489 [ sys_name,
490 sys_conc_name,
491 type,
492 sys_named,
493 sys_slot_descr
494 ],
495 arginfo{ all:
496 [ sys_name,
497 sys_conc_name,
498 type,
499 sys_named,
500 sys_slot_descr
501 ],
502 allow_other_keys:0,
503 aux:0,
504 body:0,
505 complex:0,
506 env:0,
507 key:0,
508 names:
509 [ sys_name,
510 sys_conc_name,
511 type,
512 sys_named,
513 sys_slot_descr
514 ],
515 opt:0,
516 req:
517 [ sys_name,
518 sys_conc_name,
519 type,
520 sys_named,
521 sys_slot_descr
522 ],
523 rest:0,
524 sublists:0,
525 whole:0
526 }))).
527*/
528/*
529:- side_effect(assert_lsp(sys_make_access_function,
530 init_args(x, f_sys_make_access_function))).
531*/
532/*
533; (default-init (nth 1 slot-descr))
534*/
535/*
536; (slot-type (nth 2 slot-descr))
537*/
538/*
539; If TYPE is NIL,
540*/
541/*
542; the slot is at the offset in the structure-body.
543*/
544/*
545; If TYPE is VECTOR or (VECTOR ... ), ELT is used.
546*/
547/*
548; If TYPE is LIST, NTH is used.
549*/
550/*
551; The following is used by the compiler to expand inline ;; the accessor
552*/
553/*
554(defun illegal-boa ()
555 (error "An illegal BOA constructor."))
556
557
558*/
559
560/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:1970 **********************/
561:-lisp_compile_to_prolog(pkg_sys,[defun,'illegal-boa',[],[error,'$STRING'("An illegal BOA constructor.")]])
562/*
563:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
564 sys_illegal_boa,
565 kw_function,
566 f_sys_illegal_boa)).
567*/
568wl:lambda_def(defun, sys_illegal_boa, f_sys_illegal_boa, [], [[error, '$ARRAY'([*], claz_base_character, "An illegal BOA constructor.")]]).
569wl:arglist_info(sys_illegal_boa, f_sys_illegal_boa, [], arginfo{all:0, allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[], opt:0, req:0, rest:0, sublists:0, whole:0}).
570wl: init_args(x, f_sys_illegal_boa).
571
576f_sys_illegal_boa(FnResult) :-
577 _3454=[],
578 catch(( f_error(
579 [ '$ARRAY'([*],
580 claz_base_character,
581 "An illegal BOA constructor.")
582 ],
583 Error_Ret),
584 Error_Ret=FnResult
585 ),
586 block_exit(sys_illegal_boa, FnResult),
587 true).
588:- set_opv(sys_illegal_boa, symbol_function, f_sys_illegal_boa),
589 DefunResult=sys_illegal_boa. 590/*
591:- side_effect(assert_lsp(sys_illegal_boa,
592 lambda_def(defun,
593 sys_illegal_boa,
594 f_sys_illegal_boa,
595 [],
596
597 [
598 [ error,
599 '$ARRAY'([*],
600 claz_base_character,
601 "An illegal BOA constructor.")
602 ]
603 ]))).
604*/
605/*
606:- side_effect(assert_lsp(sys_illegal_boa,
607 arglist_info(sys_illegal_boa,
608 f_sys_illegal_boa,
609 [],
610 arginfo{ all:0,
611 allow_other_keys:0,
612 aux:0,
613 body:0,
614 complex:0,
615 env:0,
616 key:0,
617 names:[],
618 opt:0,
619 req:0,
620 rest:0,
621 sublists:0,
622 whole:0
623 }))).
624*/
625/*
626:- side_effect(assert_lsp(sys_illegal_boa, init_args(x, f_sys_illegal_boa))).
627*/
628/*
629(defun make-predicate (name type named name-offset)
630 (cond ((null type)
631 #'(lambda (x)
632 (structure-subtype-p x name)))
633 ((or (eq type 'VECTOR)
634 (and (consp type) (eq (car type) 'VECTOR)))
635 ;; The name is at the NAME-OFFSET in the vector.
636 (unless named (error "The structure should be named."))
637 #'(lambda (x)
638 (and (vectorp x)
639 (> (length x) name-offset)
640 ;; AKCL has (aref (the (vector t) x).)
641 ;; which fails with strings
642 (eq (elt x name-offset) name))))
643 ((eq type 'LIST)
644 ;; The name is at the NAME-OFFSET in the list.
645 (unless named (error "The structure should be named."))
646 (if (= name-offset 0)
647 #'(lambda (x)
648 (and (consp x) (eq (car x) name)))
649 #'(lambda (x)
650 (do ((i name-offset (1- i))
651 (y x (cdr y)))
652 ((= i 0) (and (consp y) (eq (car y) name)))
653 (declare (fixnum i))
654 (unless (consp y) (return nil))))))
655 ((error ""(defun make-predicate (name type named name-offset)\n (cond ((null type)\n\t #'(lambda (x)\n\t (structure-subtype-p x name)))\n ((or (eq type 'VECTOR)\n (and (consp type) (eq (car type) 'VECTOR)))\n ;; The name is at the NAME-OFFSET in the vector.\n (unless named (error \"The structure should be named.\"))\n\t #'(lambda (x)\n\t (and (vectorp x)\n\t\t (> (length x) name-offset)\n\t\t ;; AKCL has (aref (the (vector t) x).)\n\t\t ;; which fails with strings\n\t\t (eq (elt x name-offset) name))))\n ((eq type 'LIST)\n ;; The name is at the NAME-OFFSET in the list.\n (unless named (error \"The structure should be named.\"))\n (if (= name-offset 0)\n\t #'(lambda (x)\n\t\t (and (consp x) (eq (car x) name)))\n\t #'(lambda (x)\n\t\t (do ((i name-offset (1- i))\n\t\t (y x (cdr y)))\n\t\t ((= i 0) (and (consp y) (eq (car y) name)))\n\t\t (declare (fixnum i))\n\t\t (unless (consp y) (return nil))))))\n ((error \"~S is an illegal structure type.\"))))\n\n\n;;; PARSE-SLOT-DESCRIPTION parses the given slot-description\n;;; and returns a list of the form:\n;;; (slot-name default-init slot-type read-only offset)\n\n".
656*/
657
658/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:2035 **********************/
659:-lisp_compile_to_prolog(pkg_sys,[defun,'make-predicate',[name,type,named,'name-offset'],[cond,[[null,type],function([lambda,[x],['structure-subtype-p',x,name]])],[[or,[eq,type,[quote,'VECTOR']],[and,[consp,type],[eq,[car,type],[quote,'VECTOR']]]],[unless,named,[error,'$STRING'("The structure should be named.")]],function([lambda,[x],[and,[vectorp,x],[>,[length,x],'name-offset'],[eq,[elt,x,'name-offset'],name]]])],[[eq,type,[quote,'LIST']],[unless,named,[error,'$STRING'("The structure should be named.")]],[if,[=,'name-offset',0],function([lambda,[x],[and,[consp,x],[eq,[car,x],name]]]),function([lambda,[x],[do,[[i,'name-offset',['1-',i]],[y,x,[cdr,y]]],[[=,i,0],[and,[consp,y],[eq,[car,y],name]]],[declare,[fixnum,i]],[unless,[consp,y],[return,[]]]]])]],[[error,'$STRING'("~S is an illegal structure type.")]]]])
660/*
661:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
662 sys_make_predicate,
663 kw_function,
664 f_sys_make_predicate)).
665*/
666/*
667:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
668 sys_structure_subtype_p,
669 kw_function,
670 f_sys_structure_subtype_p)).
671*/
672wl:lambda_def(defun, sys_make_predicate, f_sys_make_predicate, [sys_name, type, sys_named, sys_name_offset], [[cond, [[null, type], function([lambda, [sys_x], [sys_structure_subtype_p, sys_x, sys_name]])], [[or, [eq, type, [quote, vector]], [and, [consp, type], [eq, [car, type], [quote, vector]]]], [unless, sys_named, [error, '$ARRAY'([*], claz_base_character, "The structure should be named.")]], function([lambda, [sys_x], [and, [vectorp, sys_x], [>, [length, sys_x], sys_name_offset], [eq, [elt, sys_x, sys_name_offset], sys_name]]])], [[eq, type, [quote, list]], [unless, sys_named, [error, '$ARRAY'([*], claz_base_character, "The structure should be named.")]], [if, [=, sys_name_offset, 0], function([lambda, [sys_x], [and, [consp, sys_x], [eq, [car, sys_x], sys_name]]]), function([lambda, [sys_x], [do, [[sys_i, sys_name_offset, ['1-', sys_i]], [sys_y, sys_x, [cdr, sys_y]]], [[=, sys_i, 0], [and, [consp, sys_y], [eq, [car, sys_y], sys_name]]], [declare, [fixnum, sys_i]], [unless, [consp, sys_y], [return, []]]]])]], [[error, '$ARRAY'([*], claz_base_character, "~S is an illegal structure type.")]]]]).
673wl:arglist_info(sys_make_predicate, f_sys_make_predicate, [sys_name, type, sys_named, sys_name_offset], arginfo{all:[sys_name, type, sys_named, sys_name_offset], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_name, type, sys_named, sys_name_offset], opt:0, req:[sys_name, type, sys_named, sys_name_offset], rest:0, sublists:0, whole:0}).
674wl: init_args(x, f_sys_make_predicate).
675
680f_sys_make_predicate(Name_In, Type_In, Named_In, Name_offset_In, FnResult) :-
681 GEnv=[bv(sys_name, Name_In), bv(type, Type_In), bv(sys_named, Named_In), bv(sys_name_offset, Name_offset_In)],
682 catch(( ( get_var(GEnv, type, IFTEST),
683 ( IFTEST==[]
684 -> _8760=closure(kw_function, [ClosureEnvironment|GEnv], Whole, LResult, [sys_x], (get_var(ClosureEnvironment, sys_name, Name_Get), get_var(ClosureEnvironment, sys_x, X_Get), f_sys_structure_subtype_p(X_Get, Name_Get, LResult)), [lambda, [sys_x], [sys_structure_subtype_p, sys_x, sys_name]])
685 ; ( get_var(GEnv, type, Type_Get19),
686 f_eq(Type_Get19, vector, FORM1_Res),
687 FORM1_Res\==[],
688 IFTEST17=FORM1_Res
689 -> true
690 ; get_var(GEnv, type, Type_Get21),
691 ( c0nz:is_consp(Type_Get21)
692 -> get_var(GEnv, type, Type_Get24),
693 f_car(Type_Get24, Eq_Param),
694 f_eq(Eq_Param, vector, TrueResult),
695 _9048=TrueResult
696 ; _9048=[]
697 ),
698 IFTEST17=_9048
699 ),
700 ( IFTEST17\==[]
701 -> get_var(GEnv, sys_named, IFTEST27),
702 ( IFTEST27\==[]
703 -> _9190=[]
704 ; f_error(
705 [ '$ARRAY'([*],
706 claz_base_character,
707 "The structure should be named.")
708 ],
709 ElseResult),
710 _9190=ElseResult
711 ),
712 ElseResult146=closure(kw_function, [ClosureEnvironment48|GEnv], Whole49, LResult46, [sys_x], (get_var(ClosureEnvironment48, sys_x, X_Get32), (aray:is_vectorp(X_Get32)->get_var(ClosureEnvironment48, sys_x, X_Get36), f_length(X_Get36, PredArg1Result), get_var(ClosureEnvironment48, sys_name_offset, Name_offset_Get), (PredArg1Result>Name_offset_Get->get_var(ClosureEnvironment48, sys_name_offset, Name_offset_Get42), get_var(ClosureEnvironment48, sys_x, X_Get41), f_elt(X_Get41, Name_offset_Get42, Eq_Param153), get_var(ClosureEnvironment48, sys_name, Name_Get43), f_eq(Eq_Param153, Name_Get43, TrueResult44), TrueResult45=TrueResult44;TrueResult45=[]), LResult46=TrueResult45;LResult46=[])), [lambda, [sys_x], [and, [vectorp, sys_x], [>, [length, sys_x], sys_name_offset], [eq, [elt, sys_x, sys_name_offset], sys_name]]])
713 ; get_var(GEnv, type, Type_Get51),
714 ( is_eq(Type_Get51, list)
715 -> get_var(GEnv, sys_named, IFTEST54),
716 ( IFTEST54\==[]
717 -> _10032=[]
718 ; f_error(
719 [ '$ARRAY'([*],
720 claz_base_character,
721 "The structure should be named.")
722 ],
723 ElseResult57),
724 _10032=ElseResult57
725 ),
726 get_var(GEnv, sys_name_offset, Name_offset_Get59),
727 ( Name_offset_Get59=:=0
728 -> TrueResult143=closure(kw_function, [ClosureEnvironment71|GEnv], Whole72, LResult69, [sys_x], (get_var(ClosureEnvironment71, sys_x, X_Get63), (c0nz:is_consp(X_Get63)->get_var(ClosureEnvironment71, sys_x, X_Get66), f_car(X_Get66, Eq_Param154), get_var(ClosureEnvironment71, sys_name, Name_Get67), f_eq(Eq_Param154, Name_Get67, TrueResult68), LResult69=TrueResult68;LResult69=[])), [lambda, [sys_x], [and, [consp, sys_x], [eq, [car, sys_x], sys_name]]])
729 ; TrueResult143=closure(kw_function, [ClosureEnvironment138|GEnv], Whole139, LetResult, [sys_x], (get_var(ClosureEnvironment138, sys_name_offset, Name_offset_Get76), get_var(ClosureEnvironment138, sys_x, X_Get77), BlockExitEnv=[bv(sys_i, Name_offset_Get76), bv(sys_y, X_Get77)|ClosureEnvironment138], catch((call_addr_block(BlockExitEnv, (push_label(do_label_1), get_var(BlockExitEnv, sys_i, I_Get110), (I_Get110=:=0->get_var(BlockExitEnv, sys_y, Y_Get116), (c0nz:is_consp(Y_Get116)->get_var(BlockExitEnv, sys_y, Y_Get119), f_car(Y_Get119, Eq_Param155), get_var(BlockExitEnv, sys_name, Name_Get120), f_eq(Eq_Param155, Name_Get120, TrueResult121), RetResult113=TrueResult121;RetResult113=[]), throw(block_exit([], RetResult113)), _TBResult=ThrowResult114;sf_declare(BlockExitEnv, [fixnum, sys_i], Sf_declare_Ret), get_var(BlockExitEnv, sys_y, Y_Get124), (c0nz:is_consp(Y_Get124)->_11730=[];throw(block_exit([], [])), _11730=ThrowResult128), get_var(BlockExitEnv, sys_i, I_Get130), 'f_1-'(I_Get130, I), get_var(BlockExitEnv, sys_y, Y_Get131), f_cdr(Y_Get131, Y), set_var(BlockExitEnv, sys_i, I), set_var(BlockExitEnv, sys_y, Y), goto(do_label_1, BlockExitEnv), _TBResult=_GORES132)), [addr(addr_tagbody_1_do_label_1, do_label_1, '$unused', BlockExitEnv, (get_var(BlockExitEnv, sys_i, I_Get), (I_Get=:=0->get_var(BlockExitEnv, sys_y, Y_Get), (c0nz:is_consp(Y_Get)->get_var(BlockExitEnv, sys_y, Y_Get91), f_car(Y_Get91, Eq_Param156), get_var(BlockExitEnv, sys_name, Name_Get92), f_eq(Eq_Param156, Name_Get92, TrueResult93), Block_exit_Ret=TrueResult93;Block_exit_Ret=[]), throw(block_exit([], Block_exit_Ret)), _12106=ThrowResult;sf_declare(BlockExitEnv, [fixnum, sys_i], Sf_declare_Ret159), get_var(BlockExitEnv, sys_y, Y_Get96), (c0nz:is_consp(Y_Get96)->_12138=[];throw(block_exit([], [])), _12138=ThrowResult100), get_var(BlockExitEnv, sys_i, I_Get102), 'f_1-'(I_Get102, Set_var_Ret), get_var(BlockExitEnv, sys_y, Y_Get103), f_cdr(Y_Get103, Cdr_Ret), set_var(BlockExitEnv, sys_i, Set_var_Ret), set_var(BlockExitEnv, sys_y, Cdr_Ret), goto(do_label_1, BlockExitEnv), _12106=_GORES)))]), []=LetResult), block_exit([], LetResult), true)), [lambda, [sys_x], [do, [[sys_i, sys_name_offset, ['1-', sys_i]], [sys_y, sys_x, [cdr, sys_y]]], [[=, sys_i, 0], [and, [consp, sys_y], [eq, [car, sys_y], sys_name]]], [declare, [fixnum, sys_i]], [unless, [consp, sys_y], [return, []]]]])
730 ),
731 ElseResult145=TrueResult143
732 ; f_error(
733 [ '$ARRAY'([*],
734 claz_base_character,
735 "~S is an illegal structure type.")
736 ],
737 IFTEST140),
738 ( IFTEST140\==[]
739 -> ElseResult144=[]
740 ; ElseResult142=[],
741 ElseResult144=ElseResult142
742 ),
743 ElseResult145=ElseResult144
744 ),
745 ElseResult146=ElseResult145
746 ),
747 _8760=ElseResult146
748 )
749 ),
750 _8760=FnResult
751 ),
752 block_exit(sys_make_predicate, FnResult),
753 true).
754:- set_opv(sys_make_predicate, symbol_function, f_sys_make_predicate),
755 DefunResult=sys_make_predicate. 756/*
757:- side_effect(assert_lsp(sys_make_predicate,
758 lambda_def(defun,
759 sys_make_predicate,
760 f_sys_make_predicate,
761 [sys_name, type, sys_named, sys_name_offset],
762
763 [
764 [ cond,
765
766 [ [null, type],
767 function(
768 [ lambda,
769 [sys_x],
770
771 [ sys_structure_subtype_p,
772 sys_x,
773 sys_name
774 ]
775 ])
776 ],
777
778 [
779 [ or,
780 [eq, type, [quote, vector]],
781
782 [ and,
783 [consp, type],
784 [eq, [car, type], [quote, vector]]
785 ]
786 ],
787
788 [ unless,
789 sys_named,
790
791 [ error,
792 '$ARRAY'([*],
793 claz_base_character,
794 "The structure should be named.")
795 ]
796 ],
797 function(
798 [ lambda,
799 [sys_x],
800
801 [ and,
802 [vectorp, sys_x],
803
804 [ (>),
805 [length, sys_x],
806 sys_name_offset
807 ],
808
809 [ eq,
810
811 [ elt,
812 sys_x,
813 sys_name_offset
814 ],
815 sys_name
816 ]
817 ]
818 ])
819 ],
820
821 [ [eq, type, [quote, list]],
822
823 [ unless,
824 sys_named,
825
826 [ error,
827 '$ARRAY'([*],
828 claz_base_character,
829 "The structure should be named.")
830 ]
831 ],
832
833 [ if,
834 [=, sys_name_offset, 0],
835 function(
836 [ lambda,
837 [sys_x],
838
839 [ and,
840 [consp, sys_x],
841
842 [ eq,
843 [car, sys_x],
844 sys_name
845 ]
846 ]
847 ]),
848 function(
849 [ lambda,
850 [sys_x],
851
852 [ do,
853
854 [
855 [ sys_i,
856 sys_name_offset,
857 ['1-', sys_i]
858 ],
859
860 [ sys_y,
861 sys_x,
862 [cdr, sys_y]
863 ]
864 ],
865
866 [ [=, sys_i, 0],
867
868 [ and,
869 [consp, sys_y],
870
871 [ eq,
872 [car, sys_y],
873 sys_name
874 ]
875 ]
876 ],
877
878 [ declare,
879 [fixnum, sys_i]
880 ],
881
882 [ unless,
883 [consp, sys_y],
884 [return, []]
885 ]
886 ]
887 ])
888 ]
889 ],
890
891 [
892 [ error,
893 '$ARRAY'([*],
894 claz_base_character,
895 "~S is an illegal structure type.")
896 ]
897 ]
898 ]
899 ]))).
900*/
901/*
902:- side_effect(assert_lsp(sys_make_predicate,
903 arglist_info(sys_make_predicate,
904 f_sys_make_predicate,
905
906 [ sys_name,
907 type,
908 sys_named,
909 sys_name_offset
910 ],
911 arginfo{ all:
912 [ sys_name,
913 type,
914 sys_named,
915 sys_name_offset
916 ],
917 allow_other_keys:0,
918 aux:0,
919 body:0,
920 complex:0,
921 env:0,
922 key:0,
923 names:
924 [ sys_name,
925 type,
926 sys_named,
927 sys_name_offset
928 ],
929 opt:0,
930 req:
931 [ sys_name,
932 type,
933 sys_named,
934 sys_name_offset
935 ],
936 rest:0,
937 sublists:0,
938 whole:0
939 }))).
940*/
941/*
942:- side_effect(assert_lsp(sys_make_predicate,
943 init_args(x, f_sys_make_predicate))).
944*/
945/*
946; The name is at the NAME-OFFSET in the vector.
947*/
948/*
949; AKCL has (aref (the (vector t) x).)
950*/
951/*
952; which fails with strings
953*/
954/*
955; The name is at the NAME-OFFSET in the list.
956*/
957/*
958;; PARSE-SLOT-DESCRIPTION parses the given slot-description
959*/
960/*
961;; and returns a list of the form:
962*/
963/*
964;; (slot-name default-init slot-type read-only offset)
965*/
966/*
967(defun parse-slot-description (slot-description offset)
968 (declare (si::c-local))
969 (let* (slot-name default-init slot-type read-only)
970 (cond ((atom slot-description)
971 (setq slot-name slot-description))
972 ((endp (cdr slot-description))
973 (setq slot-name (car slot-description)))
974 (t
975 (setq slot-name (car slot-description))
976 (setq default-init (cadr slot-description))
977 (do ((os (cddr slot-description) (cddr os)) (o) (v))
978 ((endp os))
979 (setq o (car os))
980 (when (endp (cdr os))
981 (error ""(defun parse-slot-description (slot-description offset)\n (declare (si::c-local))\n (let* (slot-name default-init slot-type read-only)\n (cond ((atom slot-description)\n (setq slot-name slot-description))\n ((endp (cdr slot-description))\n (setq slot-name (car slot-description)))\n (t\n (setq slot-name (car slot-description))\n (setq default-init (cadr slot-description))\n (do ((os (cddr slot-description) (cddr os)) (o) (v))\n ((endp os))\n (setq o (car os))\n (when (endp (cdr os))\n (error \"~S is an illegal structure slot option.\"\n os))\n (setq v (cadr os))\n (case o\n (:TYPE (setq slot-type v))\n (:READ-ONLY (setq read-only v))\n (t\n (error \"~S is an illegal structure slot option.\"\n os))))))\n (list slot-name default-init slot-type read-only offset)))\n\n\n;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions\n;;; with the new descriptions which are specified in the\n;;; :include defstruct option.\n\n".
982*/
983
984/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:3200 **********************/
985:-lisp_compile_to_prolog(pkg_sys,[defun,'parse-slot-description',['slot-description',offset],[declare,['si::c-local']],['let*',['slot-name','default-init','slot-type','read-only'],[cond,[[atom,'slot-description'],[setq,'slot-name','slot-description']],[[endp,[cdr,'slot-description']],[setq,'slot-name',[car,'slot-description']]],[t,[setq,'slot-name',[car,'slot-description']],[setq,'default-init',[cadr,'slot-description']],[do,[[os,[cddr,'slot-description'],[cddr,os]],[o],[v]],[[endp,os]],[setq,o,[car,os]],[when,[endp,[cdr,os]],[error,'$STRING'("~S is an illegal structure slot option."),os]],[setq,v,[cadr,os]],[case,o,[':TYPE',[setq,'slot-type',v]],[':READ-ONLY',[setq,'read-only',v]],[t,[error,'$STRING'("~S is an illegal structure slot option."),os]]]]]],[list,'slot-name','default-init','slot-type','read-only',offset]]])
986/*
987:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
988 sys_parse_slot_description,
989 kw_function,
990 f_sys_parse_slot_description)).
991*/
992/*
993% case:-[[kw_type,[setq,sys_slot_type,sys_v]],[kw_read_only,[setq,sys_read_only,sys_v]],[t,[error,'$ARRAY'([*],claz_base_character,"~S is an illegal structure slot option."),sys_os]]].
994*/
995/*
996% conds:-[[[eq,_29578,[quote,kw_type]],[progn,[setq,sys_slot_type,sys_v]]],[[eq,_29578,[quote,kw_read_only]],[progn,[setq,sys_read_only,sys_v]]],[t,[progn,[error,'$ARRAY'([*],claz_base_character,"~S is an illegal structure slot option."),sys_os]]]].
997*/
998/*
999% case:-[[kw_type,[setq,sys_slot_type,sys_v]],[kw_read_only,[setq,sys_read_only,sys_v]],[t,[error,'$ARRAY'([*],claz_base_character,"~S is an illegal structure slot option."),sys_os]]].
1000*/
1001/*
1002% conds:-[[[eq,_32110,[quote,kw_type]],[progn,[setq,sys_slot_type,sys_v]]],[[eq,_32110,[quote,kw_read_only]],[progn,[setq,sys_read_only,sys_v]]],[t,[progn,[error,'$ARRAY'([*],claz_base_character,"~S is an illegal structure slot option."),sys_os]]]].
1003*/
1004wl:lambda_def(defun, sys_parse_slot_description, f_sys_parse_slot_description, [sys_slot_description, sys_offset], [[declare, [sys_c_local]], [let_xx, [sys_slot_name, sys_default_init, sys_slot_type, sys_read_only], [cond, [[atom, sys_slot_description], [setq, sys_slot_name, sys_slot_description]], [[endp, [cdr, sys_slot_description]], [setq, sys_slot_name, [car, sys_slot_description]]], [t, [setq, sys_slot_name, [car, sys_slot_description]], [setq, sys_default_init, [cadr, sys_slot_description]], [do, [[sys_os, [cddr, sys_slot_description], [cddr, sys_os]], [sys_o], [sys_v]], [[endp, sys_os]], [setq, sys_o, [car, sys_os]], [when, [endp, [cdr, sys_os]], [error, '$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), sys_os]], [setq, sys_v, [cadr, sys_os]], [case, sys_o, [kw_type, [setq, sys_slot_type, sys_v]], [kw_read_only, [setq, sys_read_only, sys_v]], [t, [error, '$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), sys_os]]]]]], [list, sys_slot_name, sys_default_init, sys_slot_type, sys_read_only, sys_offset]]]).
1005wl:arglist_info(sys_parse_slot_description, f_sys_parse_slot_description, [sys_slot_description, sys_offset], arginfo{all:[sys_slot_description, sys_offset], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_slot_description, sys_offset], opt:0, req:[sys_slot_description, sys_offset], rest:0, sublists:0, whole:0}).
1006wl: init_args(x, f_sys_parse_slot_description).
1007
1012f_sys_parse_slot_description(Slot_description_In, Offset_In, FnResult) :-
1013 Sf_declare_Param=[bv(sys_slot_description, Slot_description_In), bv(sys_offset, Offset_In)],
1014 catch(( ( sf_declare(Sf_declare_Param, [sys_c_local], Sf_declare_Ret),
1015 LEnv=[bv(sys_slot_name, [])|Sf_declare_Param],
1016 LEnv11=[bv(sys_default_init, [])|LEnv],
1017 LEnv14=[bv(sys_slot_type, [])|LEnv11],
1018 LEnv17=[bv(sys_read_only, [])|LEnv14],
1019 get_var(LEnv17, sys_slot_description, Slot_description_Get),
1020 ( Slot_description_Get\=[CAR|CDR]
1021 -> get_var(LEnv17,
1022 sys_slot_description,
1023 Slot_description_Get23),
1024 set_var(LEnv17, sys_slot_name, Slot_description_Get23),
1025 _7472=Slot_description_Get23
1026 ; get_var(LEnv17,
1027 sys_slot_description,
1028 Slot_description_Get25),
1029 f_cdr(Slot_description_Get25, PredArgResult27),
1030 ( s3q:is_endp(PredArgResult27)
1031 -> get_var(LEnv17,
1032 sys_slot_description,
1033 Slot_description_Get28),
1034 f_car(Slot_description_Get28, TrueResult108),
1035 set_var(LEnv17, sys_slot_name, TrueResult108),
1036 ElseResult111=TrueResult108
1037 ; get_var(LEnv17,
1038 sys_slot_description,
1039 Slot_description_Get29),
1040 f_car(Slot_description_Get29, Slot_name),
1041 set_var(LEnv17, sys_slot_name, Slot_name),
1042 get_var(LEnv17,
1043 sys_slot_description,
1044 Slot_description_Get30),
1045 f_cadr(Slot_description_Get30, Default_init),
1046 set_var(LEnv17, sys_default_init, Default_init),
1047 get_var(LEnv17,
1048 sys_slot_description,
1049 Slot_description_Get34),
1050 f_cddr(Slot_description_Get34, Os_Init),
1051 AEnv=[bv(sys_os, Os_Init), bv([sys_o], []), bv([sys_v], [])|LEnv17],
1052 catch(( call_addr_block(AEnv,
1053 (push_label(do_label_2), get_var(AEnv, sys_os, Os_Get74), (s3q:is_endp(Os_Get74)->throw(block_exit([], [])), _TBResult=ThrowResult78;get_var(AEnv, sys_os, Os_Get81), f_car(Os_Get81, O), set_var(AEnv, sys_o, O), get_var(AEnv, sys_os, Os_Get83), f_cdr(Os_Get83, PredArgResult85), (s3q:is_endp(PredArgResult85)->get_var(AEnv, sys_os, Os_Get86), f_error(['$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), Os_Get86], TrueResult87), _8910=TrueResult87;_8910=[]), get_var(AEnv, sys_os, Os_Get88), f_cadr(Os_Get88, V), set_var(AEnv, sys_v, V), get_var(AEnv, sys_o, Key), (is_eq(Key, kw_type)->get_var(AEnv, sys_v, V_Get94), set_var(AEnv, sys_slot_type, V_Get94), _8866=V_Get94;(is_eq(Key, kw_read_only)->get_var(AEnv, sys_v, V_Get97), set_var(AEnv, sys_read_only, V_Get97), ElseResult102=V_Get97;get_var(AEnv, sys_os, Os_Get98), f_error(['$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), Os_Get98], ElseResult100), ElseResult102=ElseResult100), _8866=ElseResult102), get_var(AEnv, sys_os, Os_Get103), f_cddr(Os_Get103, Os), set_var(AEnv, sys_os, Os), goto(do_label_2, AEnv), _TBResult=_GORES104)),
1054
1055 [ addr(addr_tagbody_2_do_label_2,
1056 do_label_2,
1057 '$unused',
1058 AEnv,
1059 (get_var(AEnv, sys_os, Os_Get), (s3q:is_endp(Os_Get)->throw(block_exit([], [])), _9528=ThrowResult;get_var(AEnv, sys_os, Os_Get45), f_car(Os_Get45, Car_Ret), set_var(AEnv, sys_o, Car_Ret), get_var(AEnv, sys_os, Os_Get47), f_cdr(Os_Get47, PredArgResult49), (s3q:is_endp(PredArgResult49)->get_var(AEnv, sys_os, Os_Get50), f_error(['$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), Os_Get50], Error_Ret), _9604=Error_Ret;_9604=[]), get_var(AEnv, sys_os, Os_Get52), f_cadr(Os_Get52, Cadr_Ret), set_var(AEnv, sys_v, Cadr_Ret), get_var(AEnv, sys_o, Key), (is_eq(Key, kw_type)->get_var(AEnv, sys_v, V_Get), set_var(AEnv, sys_slot_type, V_Get), _9650=V_Get;(is_eq(Key, kw_read_only)->get_var(AEnv, sys_v, V_Get61), set_var(AEnv, sys_read_only, V_Get61), ElseResult66=V_Get61;get_var(AEnv, sys_os, Os_Get62), f_error(['$ARRAY'([*], claz_base_character, "~S is an illegal structure slot option."), Os_Get62], Error_Ret131), ElseResult66=Error_Ret131), _9650=ElseResult66), get_var(AEnv, sys_os, Os_Get67), f_cddr(Os_Get67, Cddr_Ret), set_var(AEnv, sys_os, Cddr_Ret), goto(do_label_2, AEnv), _9528=_GORES)))
1060 ]),
1061 []=LetResult32
1062 ),
1063 block_exit([], LetResult32),
1064 true),
1065 ElseResult111=LetResult32
1066 ),
1067 _7472=ElseResult111
1068 ),
1069 get_var(LEnv17, sys_default_init, Default_init_Get),
1070 get_var(LEnv17, sys_offset, Offset_Get),
1071 get_var(LEnv17, sys_read_only, Read_only_Get),
1072 get_var(LEnv17, sys_slot_name, Slot_name_Get),
1073 get_var(LEnv17, sys_slot_type, Slot_type_Get),
1074 LetResult10=[Slot_name_Get, Default_init_Get, Slot_type_Get, Read_only_Get, Offset_Get]
1075 ),
1076 LetResult10=FnResult
1077 ),
1078 block_exit(sys_parse_slot_description, FnResult),
1079 true).
1080:- set_opv(sys_parse_slot_description,
1081 symbol_function,
1082 f_sys_parse_slot_description),
1083 DefunResult=sys_parse_slot_description. 1084/*
1085:- side_effect(assert_lsp(sys_parse_slot_description,
1086 lambda_def(defun,
1087 sys_parse_slot_description,
1088 f_sys_parse_slot_description,
1089 [sys_slot_description, sys_offset],
1090
1091 [ [declare, [sys_c_local]],
1092
1093 [ let_xx,
1094
1095 [ sys_slot_name,
1096 sys_default_init,
1097 sys_slot_type,
1098 sys_read_only
1099 ],
1100
1101 [ cond,
1102
1103 [ [atom, sys_slot_description],
1104
1105 [ setq,
1106 sys_slot_name,
1107 sys_slot_description
1108 ]
1109 ],
1110
1111 [ [endp, [cdr, sys_slot_description]],
1112
1113 [ setq,
1114 sys_slot_name,
1115 [car, sys_slot_description]
1116 ]
1117 ],
1118
1119 [ t,
1120
1121 [ setq,
1122 sys_slot_name,
1123 [car, sys_slot_description]
1124 ],
1125
1126 [ setq,
1127 sys_default_init,
1128 [cadr, sys_slot_description]
1129 ],
1130
1131 [ do,
1132
1133 [
1134 [ sys_os,
1135 [cddr, sys_slot_description],
1136 [cddr, sys_os]
1137 ],
1138 [sys_o],
1139 [sys_v]
1140 ],
1141 [[endp, sys_os]],
1142 [setq, sys_o, [car, sys_os]],
1143
1144 [ when,
1145 [endp, [cdr, sys_os]],
1146
1147 [ error,
1148 '$ARRAY'([*],
1149 claz_base_character,
1150 "~S is an illegal structure slot option."),
1151 sys_os
1152 ]
1153 ],
1154 [setq, sys_v, [cadr, sys_os]],
1155
1156 [ case,
1157 sys_o,
1158
1159 [ kw_type,
1160 [setq, sys_slot_type, sys_v]
1161 ],
1162
1163 [ kw_read_only,
1164 [setq, sys_read_only, sys_v]
1165 ],
1166
1167 [ t,
1168
1169 [ error,
1170 '$ARRAY'([*],
1171 claz_base_character,
1172 "~S is an illegal structure slot option."),
1173 sys_os
1174 ]
1175 ]
1176 ]
1177 ]
1178 ]
1179 ],
1180
1181 [ list,
1182 sys_slot_name,
1183 sys_default_init,
1184 sys_slot_type,
1185 sys_read_only,
1186 sys_offset
1187 ]
1188 ]
1189 ]))).
1190*/
1191/*
1192:- side_effect(assert_lsp(sys_parse_slot_description,
1193 arglist_info(sys_parse_slot_description,
1194 f_sys_parse_slot_description,
1195 [sys_slot_description, sys_offset],
1196 arginfo{ all:
1197 [ sys_slot_description,
1198 sys_offset
1199 ],
1200 allow_other_keys:0,
1201 aux:0,
1202 body:0,
1203 complex:0,
1204 env:0,
1205 key:0,
1206 names:
1207 [ sys_slot_description,
1208 sys_offset
1209 ],
1210 opt:0,
1211 req:
1212 [ sys_slot_description,
1213 sys_offset
1214 ],
1215 rest:0,
1216 sublists:0,
1217 whole:0
1218 }))).
1219*/
1220/*
1221:- side_effect(assert_lsp(sys_parse_slot_description,
1222 init_args(x, f_sys_parse_slot_description))).
1223*/
1224/*
1225;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
1226*/
1227/*
1228;; with the new descriptions which are specified in the
1229*/
1230/*
1231;; :include defstruct option.
1232*/
1233/*
1234(defun overwrite-slot-descriptions (news olds)
1235 (declare (si::c-local))
1236 (when olds
1237 (let ((sds (member (caar olds) news :key #'car)))
1238 (cond (sds
1239 (when (and (null (cadddr (car sds)))
1240 (cadddr (car olds)))
1241 ;; If read-only is true in the old
1242 ;; and false in the new, signal an error.
1243 (error ""(defun overwrite-slot-descriptions (news olds)\n (declare (si::c-local))\n (when olds\n (let ((sds (member (caar olds) news :key #'car)))\n (cond (sds\n (when (and (null (cadddr (car sds)))\n (cadddr (car olds)))\n ;; If read-only is true in the old\n ;; and false in the new, signal an error.\n (error \"~S is an illegal include slot-description.\"\n sds))\n (cons (list (caar sds)\n (cadar sds)\n (caddar sds)\n (cadddr (car sds))\n ;; The offset if from the old.\n (car (cddddr (car olds))))\n (overwrite-slot-descriptions news (cdr olds))))\n (t\n (cons (car olds)\n (overwrite-slot-descriptions news (cdr olds))))))))\n\n\n".
1244*/
1245
1246/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:4368 **********************/
1247:-lisp_compile_to_prolog(pkg_sys,[defun,'overwrite-slot-descriptions',[news,olds],[declare,['si::c-local']],[when,olds,[let,[[sds,[member,[caar,olds],news,':key',function(car)]]],[cond,[sds,[when,[and,[null,[cadddr,[car,sds]]],[cadddr,[car,olds]]],[error,'$STRING'("~S is an illegal include slot-description."),sds]],[cons,[list,[caar,sds],[cadar,sds],[caddar,sds],[cadddr,[car,sds]],[car,[cddddr,[car,olds]]]],['overwrite-slot-descriptions',news,[cdr,olds]]]],[t,[cons,[car,olds],['overwrite-slot-descriptions',news,[cdr,olds]]]]]]]])
1248/*
1249:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1250 sys_overwrite_slot_descriptions,
1251 kw_function,
1252 f_sys_overwrite_slot_descriptions)).
1253*/
1254wl:lambda_def(defun, sys_overwrite_slot_descriptions, f_sys_overwrite_slot_descriptions, [sys_news, sys_olds], [[declare, [sys_c_local]], [when, sys_olds, [let, [[sys_sds, [member, [caar, sys_olds], sys_news, kw_key, function(car)]]], [cond, [sys_sds, [when, [and, [null, [cadddr, [car, sys_sds]]], [cadddr, [car, sys_olds]]], [error, '$ARRAY'([*], claz_base_character, "~S is an illegal include slot-description."), sys_sds]], [cons, [list, [caar, sys_sds], [cadar, sys_sds], [caddar, sys_sds], [cadddr, [car, sys_sds]], [car, [cddddr, [car, sys_olds]]]], [sys_overwrite_slot_descriptions, sys_news, [cdr, sys_olds]]]], [t, [cons, [car, sys_olds], [sys_overwrite_slot_descriptions, sys_news, [cdr, sys_olds]]]]]]]]).
1255wl:arglist_info(sys_overwrite_slot_descriptions, f_sys_overwrite_slot_descriptions, [sys_news, sys_olds], arginfo{all:[sys_news, sys_olds], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_news, sys_olds], opt:0, req:[sys_news, sys_olds], rest:0, sublists:0, whole:0}).
1256wl: init_args(x, f_sys_overwrite_slot_descriptions).
1257
1262f_sys_overwrite_slot_descriptions(News_In, Olds_In, FnResult) :-
1263 GEnv=[bv(sys_news, News_In), bv(sys_olds, Olds_In)],
1264 catch(( ( sf_declare(GEnv, [sys_c_local], Sf_declare_Ret),
1265 get_var(GEnv, sys_olds, IFTEST),
1266 ( IFTEST\==[]
1267 -> get_var(GEnv, sys_olds, Olds_Get12),
1268 f_caar(Olds_Get12, Member_Param),
1269 get_var(GEnv, sys_news, News_Get),
1270 f_member(Member_Param, News_Get, [kw_key, f_car], Sds_Init),
1271 LEnv=[bv(sys_sds, Sds_Init)|GEnv],
1272 get_var(LEnv, sys_sds, IFTEST15),
1273 ( IFTEST15\==[]
1274 -> get_var(LEnv, sys_sds, Sds_Get22),
1275 f_car(Sds_Get22, Cadddr_Param),
1276 f_cadddr(Cadddr_Param, IFTEST20),
1277 ( IFTEST20==[]
1278 -> get_var(LEnv, sys_olds, Olds_Get23),
1279 f_car(Olds_Get23, Cadddr_Param45),
1280 f_cadddr(Cadddr_Param45, TrueResult),
1281 IFTEST18=TrueResult
1282 ; IFTEST18=[]
1283 ),
1284 ( IFTEST18\==[]
1285 -> get_var(LEnv, sys_sds, Sds_Get25),
1286 f_error(
1287 [ '$ARRAY'([*],
1288 claz_base_character,
1289 "~S is an illegal include slot-description."),
1290 Sds_Get25
1291 ],
1292 TrueResult26),
1293 _6260=TrueResult26
1294 ; _6260=[]
1295 ),
1296 get_var(LEnv, sys_sds, Sds_Get27),
1297 f_caar(Sds_Get27, Caar_Ret),
1298 get_var(LEnv, sys_sds, Sds_Get28),
1299 f_cadar(Sds_Get28, Cadar_Ret),
1300 get_var(LEnv, sys_sds, Sds_Get29),
1301 f_caddar(Sds_Get29, Caddar_Ret),
1302 get_var(LEnv, sys_sds, Sds_Get30),
1303 f_car(Sds_Get30, Cadddr_Param46),
1304 f_cadddr(Cadddr_Param46, Cadddr_Ret),
1305 get_var(LEnv, sys_olds, Olds_Get31),
1306 f_car(Olds_Get31, Cddddr_Param),
1307 f_cddddr(Cddddr_Param, Car_Param),
1308 f_car(Car_Param, Car_Ret),
1309 CAR=[Caar_Ret, Cadar_Ret, Caddar_Ret, Cadddr_Ret, Car_Ret],
1310 get_var(LEnv, sys_news, News_Get32),
1311 get_var(LEnv, sys_olds, Olds_Get33),
1312 f_cdr(Olds_Get33, Cdr_Ret),
1313 f_sys_overwrite_slot_descriptions(News_Get32,
1314 Cdr_Ret,
1315 Slot_descriptions_Ret),
1316 TrueResult37=[CAR|Slot_descriptions_Ret],
1317 LetResult=TrueResult37
1318 ; get_var(LEnv, sys_olds, Olds_Get34),
1319 f_car(Olds_Get34, Car_Ret58),
1320 get_var(LEnv, sys_news, News_Get35),
1321 get_var(LEnv, sys_olds, Olds_Get36),
1322 f_cdr(Olds_Get36, Cdr_Ret59),
1323 f_sys_overwrite_slot_descriptions(News_Get35,
1324 Cdr_Ret59,
1325 Slot_descriptions_Ret60),
1326 ElseResult=[Car_Ret58|Slot_descriptions_Ret60],
1327 LetResult=ElseResult
1328 ),
1329 _6036=LetResult
1330 ; _6036=[]
1331 )
1332 ),
1333 _6036=FnResult
1334 ),
1335 block_exit(sys_overwrite_slot_descriptions, FnResult),
1336 true).
1337:- set_opv(sys_overwrite_slot_descriptions,
1338 symbol_function,
1339 f_sys_overwrite_slot_descriptions),
1340 DefunResult=sys_overwrite_slot_descriptions. 1341/*
1342:- side_effect(assert_lsp(sys_overwrite_slot_descriptions,
1343 lambda_def(defun,
1344 sys_overwrite_slot_descriptions,
1345 f_sys_overwrite_slot_descriptions,
1346 [sys_news, sys_olds],
1347
1348 [ [declare, [sys_c_local]],
1349
1350 [ when,
1351 sys_olds,
1352
1353 [ let,
1354
1355 [
1356 [ sys_sds,
1357
1358 [ member,
1359 [caar, sys_olds],
1360 sys_news,
1361 kw_key,
1362 function(car)
1363 ]
1364 ]
1365 ],
1366
1367 [ cond,
1368
1369 [ sys_sds,
1370
1371 [ when,
1372
1373 [ and,
1374
1375 [ null,
1376 [cadddr, [car, sys_sds]]
1377 ],
1378 [cadddr, [car, sys_olds]]
1379 ],
1380
1381 [ error,
1382 '$ARRAY'([*],
1383 claz_base_character,
1384 "~S is an illegal include slot-description."),
1385 sys_sds
1386 ]
1387 ],
1388
1389 [ cons,
1390
1391 [ list,
1392 [caar, sys_sds],
1393 [cadar, sys_sds],
1394 [caddar, sys_sds],
1395 [cadddr, [car, sys_sds]],
1396
1397 [ car,
1398 [cddddr, [car, sys_olds]]
1399 ]
1400 ],
1401
1402 [ sys_overwrite_slot_descriptions,
1403 sys_news,
1404 [cdr, sys_olds]
1405 ]
1406 ]
1407 ],
1408
1409 [ t,
1410
1411 [ cons,
1412 [car, sys_olds],
1413
1414 [ sys_overwrite_slot_descriptions,
1415 sys_news,
1416 [cdr, sys_olds]
1417 ]
1418 ]
1419 ]
1420 ]
1421 ]
1422 ]
1423 ]))).
1424*/
1425/*
1426:- side_effect(assert_lsp(sys_overwrite_slot_descriptions,
1427 arglist_info(sys_overwrite_slot_descriptions,
1428 f_sys_overwrite_slot_descriptions,
1429 [sys_news, sys_olds],
1430 arginfo{ all:[sys_news, sys_olds],
1431 allow_other_keys:0,
1432 aux:0,
1433 body:0,
1434 complex:0,
1435 env:0,
1436 key:0,
1437 names:[sys_news, sys_olds],
1438 opt:0,
1439 req:[sys_news, sys_olds],
1440 rest:0,
1441 sublists:0,
1442 whole:0
1443 }))).
1444*/
1445/*
1446:- side_effect(assert_lsp(sys_overwrite_slot_descriptions,
1447 init_args(x, f_sys_overwrite_slot_descriptions))).
1448*/
1449/*
1450; If read-only is true in the old
1451*/
1452/*
1453; and false in the new, signal an error.
1454*/
1455/*
1456; The offset if from the old.
1457*/
1458/*
1459(defun define-structure (name conc-name type named slots slot-descriptions
1460 copier include print-function constructors
1461 offset documentation)
1462 (put-sysprop name 'DEFSTRUCT-FORM `(defstruct ,name ,@slots))
1463 (put-sysprop name 'IS-A-STRUCTURE t)
1464 (put-sysprop name 'STRUCTURE-SLOT-DESCRIPTIONS slot-descriptions)
1465 (put-sysprop name 'STRUCTURE-INCLUDE include)
1466 (put-sysprop name 'STRUCTURE-PRINT-FUNCTION print-function)
1467 (put-sysprop name 'STRUCTURE-TYPE type)
1468 (put-sysprop name 'STRUCTURE-NAMED named)
1469 (put-sysprop name 'STRUCTURE-OFFSET offset)
1470 (put-sysprop name 'STRUCTURE-CONSTRUCTORS constructors)
1471 #+clos
1472 (when *keep-documentation*
1473 (sys:set-documentation name 'STRUCTURE documentation))
1474 (and (consp type) (eq (car type) 'VECTOR)
1475 (setq type 'VECTOR))
1476 (dolist (x slot-descriptions)
1477 (and x (car x)
1478 (funcall #'make-access-function name conc-name type named x)))
1479 (when copier
1480 (fset copier
1481 (ecase type
1482 ((NIL) #'sys::copy-structure)
1483 (LIST #'copy-list)
1484 (VECTOR #'copy-seq))))
1485 )
1486
1487
1488;; Set the dispatch macro.
1489*/
1490
1491/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:5323 **********************/
1492:-lisp_compile_to_prolog(pkg_sys,[defun,'define-structure',[name,'conc-name',type,named,slots,'slot-descriptions',copier,include,'print-function',constructors,offset,documentation],['put-sysprop',name,[quote,'DEFSTRUCT-FORM'],['#BQ',[defstruct,['#COMMA',name],['#BQ-COMMA-ELIPSE',slots]]]],['put-sysprop',name,[quote,'IS-A-STRUCTURE'],t],['put-sysprop',name,[quote,'STRUCTURE-SLOT-DESCRIPTIONS'],'slot-descriptions'],['put-sysprop',name,[quote,'STRUCTURE-INCLUDE'],include],['put-sysprop',name,[quote,'STRUCTURE-PRINT-FUNCTION'],'print-function'],['put-sysprop',name,[quote,'STRUCTURE-TYPE'],type],['put-sysprop',name,[quote,'STRUCTURE-NAMED'],named],['put-sysprop',name,[quote,'STRUCTURE-OFFSET'],offset],['put-sysprop',name,[quote,'STRUCTURE-CONSTRUCTORS'],constructors],[and,[consp,type],[eq,[car,type],[quote,'VECTOR']],[setq,type,[quote,'VECTOR']]],[dolist,[x,'slot-descriptions'],[and,x,[car,x],[funcall,function('make-access-function'),name,'conc-name',type,named,x]]],[when,copier,[fset,copier,[ecase,type,[[[]],function('sys::copy-structure')],['LIST',function('copy-list')],['VECTOR',function('copy-seq')]]]]])
1493/*
1494:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1495 sys_define_structure,
1496 kw_function,
1497 f_sys_define_structure)).
1498*/
1499/*
1500% ecase:-[[[[]],function(copy_structure)],[list,function(copy_list)],[vector,function(copy_seq)]].
1501*/
1502/*
1503% conds:-[[[eq,_21118,[quote,[]]],[progn,function(copy_structure)]],[[eq,_21118,[quote,list]],[progn,function(copy_list)]],[[eq,_21118,[quote,vector]],[progn,function(copy_seq)]],[t,[type_error,_21374,[quote,[member,[],list,vector]]]]].
1504*/
1505/*
1506:-side_effect(generate_function_or_macro_name([name='GLOBAL',environ=env_1],type_error,kw_function,f_type_error)).
1507*/
1508wl:lambda_def(defun, sys_define_structure, f_sys_define_structure, [sys_name, sys_conc_name, type, sys_named, sys_slots, sys_slot_descriptions, sys_copier, sys_include, sys_print_function, sys_constructors, sys_offset, documentation], [[sys_put_sysprop, sys_name, [quote, sys_defstruct_form], ['#BQ', [defstruct, ['#COMMA', sys_name], ['#BQ-COMMA-ELIPSE', sys_slots]]]], [sys_put_sysprop, sys_name, [quote, sys_is_a_structure], t], [sys_put_sysprop, sys_name, [quote, sys_structure_slot_descriptions], sys_slot_descriptions], [sys_put_sysprop, sys_name, [quote, sys_structure_include], sys_include], [sys_put_sysprop, sys_name, [quote, sys_structure_print_function], sys_print_function], [sys_put_sysprop, sys_name, [quote, sys_structure_type], type], [sys_put_sysprop, sys_name, [quote, sys_structure_named], sys_named], [sys_put_sysprop, sys_name, [quote, sys_structure_offset], sys_offset], [sys_put_sysprop, sys_name, [quote, sys_structure_constructors], sys_constructors], [and, [consp, type], [eq, [car, type], [quote, vector]], [setq, type, [quote, vector]]], [dolist, [sys_x, sys_slot_descriptions], [and, sys_x, [car, sys_x], [funcall, function(sys_make_access_function), sys_name, sys_conc_name, type, sys_named, sys_x]]], [when, sys_copier, [sys_fset, sys_copier, [ecase, type, [[[]], function(copy_structure)], [list, function(copy_list)], [vector, function(copy_seq)]]]]]).
1509wl:arglist_info(sys_define_structure, f_sys_define_structure, [sys_name, sys_conc_name, type, sys_named, sys_slots, sys_slot_descriptions, sys_copier, sys_include, sys_print_function, sys_constructors, sys_offset, documentation], arginfo{all:[sys_name, sys_conc_name, type, sys_named, sys_slots, sys_slot_descriptions, sys_copier, sys_include, sys_print_function, sys_constructors, sys_offset, documentation], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_name, sys_conc_name, type, sys_named, sys_slots, sys_slot_descriptions, sys_copier, sys_include, sys_print_function, sys_constructors, sys_offset, documentation], opt:0, req:[sys_name, sys_conc_name, type, sys_named, sys_slots, sys_slot_descriptions, sys_copier, sys_include, sys_print_function, sys_constructors, sys_offset, documentation], rest:0, sublists:0, whole:0}).
1510wl: init_args(x, f_sys_define_structure).
1511
1516f_sys_define_structure(Name_In, Conc_name_In, Type_In, Named_In, Slots_In, Slot_descriptions_In, Copier_In, Include_In, Print_function_In, Constructors_In, Offset_In, Documentation_In, FnResult) :-
1517 AEnv=[bv(sys_name, Name_In), bv(sys_conc_name, Conc_name_In), bv(type, Type_In), bv(sys_named, Named_In), bv(sys_slots, Slots_In), bv(sys_slot_descriptions, Slot_descriptions_In), bv(sys_copier, Copier_In), bv(sys_include, Include_In), bv(sys_print_function, Print_function_In), bv(sys_constructors, Constructors_In), bv(sys_offset, Offset_In), bv(documentation, Documentation_In)],
1518 catch(( ( get_var(AEnv, sys_name, Name_Get17),
1519 get_var(AEnv, sys_slots, Slots_Get),
1520 f_sys_put_sysprop(Name_Get17,
1521 sys_defstruct_form,
1522 [defstruct, Name_Get17|Slots_Get],
1523 [],
1524 Put_sysprop_Ret),
1525 get_var(AEnv, sys_name, Name_Get19),
1526 f_sys_put_sysprop(Name_Get19,
1527 sys_is_a_structure,
1528 t,
1529 [],
1530 Put_sysprop_Ret82),
1531 get_var(AEnv, sys_name, Name_Get20),
1532 get_var(AEnv, sys_slot_descriptions, Slot_descriptions_Get),
1533 f_sys_put_sysprop(Name_Get20,
1534 sys_structure_slot_descriptions,
1535 Slot_descriptions_Get,
1536 [],
1537 Put_sysprop_Ret83),
1538 get_var(AEnv, sys_include, Include_Get),
1539 get_var(AEnv, sys_name, Name_Get22),
1540 f_sys_put_sysprop(Name_Get22,
1541 sys_structure_include,
1542 Include_Get,
1543 [],
1544 Put_sysprop_Ret84),
1545 get_var(AEnv, sys_name, Name_Get24),
1546 get_var(AEnv, sys_print_function, Print_function_Get),
1547 f_sys_put_sysprop(Name_Get24,
1548 sys_structure_print_function,
1549 Print_function_Get,
1550 [],
1551 Put_sysprop_Ret85),
1552 get_var(AEnv, sys_name, Name_Get26),
1553 get_var(AEnv, type, Type_Get),
1554 f_sys_put_sysprop(Name_Get26,
1555 sys_structure_type,
1556 Type_Get,
1557 [],
1558 Put_sysprop_Ret86),
1559 get_var(AEnv, sys_name, Name_Get28),
1560 get_var(AEnv, sys_named, Named_Get),
1561 f_sys_put_sysprop(Name_Get28,
1562 sys_structure_named,
1563 Named_Get,
1564 [],
1565 Put_sysprop_Ret87),
1566 get_var(AEnv, sys_name, Name_Get30),
1567 get_var(AEnv, sys_offset, Offset_Get),
1568 f_sys_put_sysprop(Name_Get30,
1569 sys_structure_offset,
1570 Offset_Get,
1571 [],
1572 Put_sysprop_Ret88),
1573 get_var(AEnv, sys_constructors, Constructors_Get),
1574 get_var(AEnv, sys_name, Name_Get32),
1575 f_sys_put_sysprop(Name_Get32,
1576 sys_structure_constructors,
1577 Constructors_Get,
1578 [],
1579 Put_sysprop_Ret89),
1580 get_var(AEnv, type, Type_Get35),
1581 ( c0nz:is_consp(Type_Get35)
1582 -> get_var(AEnv, type, Type_Get39),
1583 f_car(Type_Get39, PredArg1Result),
1584 ( is_eq(PredArg1Result, vector)
1585 -> set_var(AEnv, type, vector),
1586 TrueResult=vector
1587 ; TrueResult=[]
1588 ),
1589 _7586=TrueResult
1590 ; _7586=[]
1591 ),
1592 get_var(AEnv, sys_slot_descriptions, Slot_descriptions_Get44),
1593 BV=bv(sys_x, Ele),
1594 Env2=[BV|AEnv],
1595 forall(member(Ele, Slot_descriptions_Get44),
1596 ( nb_setarg(2, BV, Ele),
1597 get_var(Env2, sys_x, IFTEST45),
1598 ( IFTEST45\==[]
1599 -> get_var(Env2, sys_x, X_Get50),
1600 f_car(X_Get50, IFTEST48),
1601 ( IFTEST48\==[]
1602 -> get_var(Env2, sys_conc_name, Conc_name_Get),
1603 get_var(Env2, sys_name, Name_Get51),
1604 get_var(Env2, sys_named, Named_Get54),
1605 ( get_var(Env2, sys_x, X_Get55),
1606 get_var(Env2, type, Type_Get53)
1607 ),
1608 f_sys_make_access_function(Name_Get51,
1609 Conc_name_Get,
1610 Type_Get53,
1611 Named_Get54,
1612 X_Get55,
1613 TrueResult56),
1614 TrueResult57=TrueResult56
1615 ; TrueResult57=[]
1616 ),
1617 _7780=TrueResult57
1618 ; _7780=[]
1619 )
1620 )),
1621 get_var(AEnv, sys_copier, IFTEST62),
1622 ( IFTEST62\==[]
1623 -> get_var(AEnv, sys_copier, Copier_Get65),
1624 get_var(AEnv, type, Key),
1625 ( is_eq(Key, [])
1626 -> _8262=f_copy_structure
1627 ; ( is_eq(Key, list)
1628 -> ElseResult77=f_copy_list
1629 ; ( is_eq(Key, vector)
1630 -> ElseResult76=f_copy_seq
1631 ; f_type_error(Type_Get66,
1632 [member, [], list, vector],
1633 ElseResult),
1634 ElseResult76=ElseResult
1635 ),
1636 ElseResult77=ElseResult76
1637 ),
1638 _8262=ElseResult77
1639 ),
1640 f_sys_fset(Copier_Get65, _8262, TrueResult78),
1641 _7170=TrueResult78
1642 ; _7170=[]
1643 )
1644 ),
1645 _7170=FnResult
1646 ),
1647 block_exit(sys_define_structure, FnResult),
1648 true).
1649:- set_opv(sys_define_structure, symbol_function, f_sys_define_structure),
1650 DefunResult=sys_define_structure. 1651/*
1652:- side_effect(assert_lsp(sys_define_structure,
1653 lambda_def(defun,
1654 sys_define_structure,
1655 f_sys_define_structure,
1656
1657 [ sys_name,
1658 sys_conc_name,
1659 type,
1660 sys_named,
1661 sys_slots,
1662 sys_slot_descriptions,
1663 sys_copier,
1664 sys_include,
1665 sys_print_function,
1666 sys_constructors,
1667 sys_offset,
1668 documentation
1669 ],
1670
1671 [
1672 [ sys_put_sysprop,
1673 sys_name,
1674 [quote, sys_defstruct_form],
1675
1676 [ '#BQ',
1677
1678 [ defstruct,
1679 ['#COMMA', sys_name],
1680 ['#BQ-COMMA-ELIPSE', sys_slots]
1681 ]
1682 ]
1683 ],
1684
1685 [ sys_put_sysprop,
1686 sys_name,
1687 [quote, sys_is_a_structure],
1688 t
1689 ],
1690
1691 [ sys_put_sysprop,
1692 sys_name,
1693
1694 [ quote,
1695 sys_structure_slot_descriptions
1696 ],
1697 sys_slot_descriptions
1698 ],
1699
1700 [ sys_put_sysprop,
1701 sys_name,
1702 [quote, sys_structure_include],
1703 sys_include
1704 ],
1705
1706 [ sys_put_sysprop,
1707 sys_name,
1708 [quote, sys_structure_print_function],
1709 sys_print_function
1710 ],
1711
1712 [ sys_put_sysprop,
1713 sys_name,
1714 [quote, sys_structure_type],
1715 type
1716 ],
1717
1718 [ sys_put_sysprop,
1719 sys_name,
1720 [quote, sys_structure_named],
1721 sys_named
1722 ],
1723
1724 [ sys_put_sysprop,
1725 sys_name,
1726 [quote, sys_structure_offset],
1727 sys_offset
1728 ],
1729
1730 [ sys_put_sysprop,
1731 sys_name,
1732 [quote, sys_structure_constructors],
1733 sys_constructors
1734 ],
1735
1736 [ and,
1737 [consp, type],
1738 [eq, [car, type], [quote, vector]],
1739 [setq, type, [quote, vector]]
1740 ],
1741
1742 [ dolist,
1743 [sys_x, sys_slot_descriptions],
1744
1745 [ and,
1746 sys_x,
1747 [car, sys_x],
1748
1749 [ funcall,
1750 function(sys_make_access_function),
1751 sys_name,
1752 sys_conc_name,
1753 type,
1754 sys_named,
1755 sys_x
1756 ]
1757 ]
1758 ],
1759
1760 [ when,
1761 sys_copier,
1762
1763 [ sys_fset,
1764 sys_copier,
1765
1766 [ ecase,
1767 type,
1768 [[[]], function(copy_structure)],
1769 [list, function(copy_list)],
1770 [vector, function(copy_seq)]
1771 ]
1772 ]
1773 ]
1774 ]))).
1775*/
1776/*
1777:- side_effect(assert_lsp(sys_define_structure,
1778 arglist_info(sys_define_structure,
1779 f_sys_define_structure,
1780
1781 [ sys_name,
1782 sys_conc_name,
1783 type,
1784 sys_named,
1785 sys_slots,
1786 sys_slot_descriptions,
1787 sys_copier,
1788 sys_include,
1789 sys_print_function,
1790 sys_constructors,
1791 sys_offset,
1792 documentation
1793 ],
1794 arginfo{ all:
1795 [ sys_name,
1796 sys_conc_name,
1797 type,
1798 sys_named,
1799 sys_slots,
1800 sys_slot_descriptions,
1801 sys_copier,
1802 sys_include,
1803 sys_print_function,
1804 sys_constructors,
1805 sys_offset,
1806 documentation
1807 ],
1808 allow_other_keys:0,
1809 aux:0,
1810 body:0,
1811 complex:0,
1812 env:0,
1813 key:0,
1814 names:
1815 [ sys_name,
1816 sys_conc_name,
1817 type,
1818 sys_named,
1819 sys_slots,
1820 sys_slot_descriptions,
1821 sys_copier,
1822 sys_include,
1823 sys_print_function,
1824 sys_constructors,
1825 sys_offset,
1826 documentation
1827 ],
1828 opt:0,
1829 req:
1830 [ sys_name,
1831 sys_conc_name,
1832 type,
1833 sys_named,
1834 sys_slots,
1835 sys_slot_descriptions,
1836 sys_copier,
1837 sys_include,
1838 sys_print_function,
1839 sys_constructors,
1840 sys_offset,
1841 documentation
1842 ],
1843 rest:0,
1844 sublists:0,
1845 whole:0
1846 }))).
1847*/
1848/*
1849:- side_effect(assert_lsp(sys_define_structure,
1850 init_args(x, f_sys_define_structure))).
1851*/
1852/*
1853; Set the dispatch macro.
1854*/
1855/*
1856(set-dispatch-macro-character #\# #\s 'sharp-s-reader)
1857*/
1858
1859/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:6404 **********************/
1860:-lisp_compile_to_prolog(pkg_sys,['set-dispatch-macro-character',#\(#),#\(s),[quote,'sharp-s-reader']])
1861:- f_set_dispatch_macro_character(#\(#), #\(s), sys_sharp_s_reader, _Ignored).
1862/*
1863(set-dispatch-macro-character #\# #\S 'sharp-s-reader)
1864
1865
1866;; Examples from Common Lisp Reference Manual.
1867
1868#|
1869*/
1870
1871/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp:6459 **********************/
1872:-lisp_compile_to_prolog(pkg_sys,['set-dispatch-macro-character',#\(#),#\('S'),[quote,'sharp-s-reader']])
1873:- f_set_dispatch_macro_character(#\(#), #\('S'), sys_sharp_s_reader, _Ignored).
1911
1912