1#!/usr/bin/env swipl
    2%; WAM-CL translated Lisp File (see https://github.com/logicmoo/wam_common_lisp/tree/master/prolog/wam_cl )
    3%; File: "lib/lsp/defstruct" (/home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/defstruct.lsp)
    4%; PWD: /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/
    5%; Start time: Sun Jan 28 04:24:00 2018
    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
  169/*
  170
  171### Compiled Function: `SYS::MAKE-ACCESS-FUNCTION` 
  172*/
  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
  572/*
  573
  574### Compiled Function: `SYS::ILLEGAL-BOA` 
  575*/
  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
  676/*
  677
  678### Compiled Function: `SYS::MAKE-PREDICATE` 
  679*/
  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
 1008/*
 1009
 1010### Compiled Function: `SYS::PARSE-SLOT-DESCRIPTION` 
 1011*/
 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
 1258/*
 1259
 1260### Compiled Function: `SYS::OVERWRITE-SLOT-DESCRIPTIONS` 
 1261*/
 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
 1512/*
 1513
 1514### Compiled Function: `SYS::DEFINE-STRUCTURE` 
 1515*/
 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).
 1874/*
 1875; Examples from Common Lisp Reference Manual.
 1876*/
 1877/*
 1878
 1879(defstruct ship
 1880  x-position
 1881  y-position
 1882  x-velocity
 1883  y-velocity
 1884  mass)
 1885
 1886(defstruct person name age sex)
 1887
 1888(defstruct (astronaut (:include person (age 45))
 1889                      (:conc-name astro-))
 1890  helmet-size
 1891  (favorite-beverage 'tang))
 1892
 1893(defstruct (foo (:constructor create-foo (a
 1894                                          &optional b (c 'sea)
 1895                                          &rest d
 1896                                          &aux e (f 'eff))))
 1897  a (b 'bee) c d e f)
 1898
 1899(defstruct (binop (:type list) :named (:initial-offset 2))
 1900  (operator '?)
 1901  operand-1
 1902  operand-2)
 1903
 1904(defstruct (annotated-binop (:type list)
 1905                            (:initial-offset 3)
 1906                            (:include binop))
 1907  commutative
 1908  associative
 1909  identity)
 1910*/
 1911
 1912
 1913%; Total compilation time: 6.615 seconds