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