much being moved to sys_

prolog/wam_cl/arglists.pl

@@ -356,26 +356,27 @@
 opt_var(Env, Var, FinalResult, G, Default, _Nth, _Optionals):-  G, FinalResult=Value,FinalResult=Default,set_var(Env,Var,Value).
 
 align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,_ArgInfo,RequiredArgs,wl:init_args(x,FN)):- 
-  eval_uses_exact(FN),!,
+  get_init_args(FN,x),!,
   LB = true,
   RestNKeys = _,
   RequiredArgs =WholeMinusSymbol.
 
-% invoke([r1,r2,r3],RET).
-align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,_ArgInfo,PARAMS,wl:init_args(bind_parameters,FN)):-
-  eval_uses_bind_parameters(FN),!,
-  LB = append(RequiredArgs,RestNKeys,WholeMinusSymbol),
+% invoke([fn,r1,r2,r3],RET).
+align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,_ArgInfo,PARAMS,wl:init_args(whole,FN)):-
+  eval_bind_parameters(FN),!,
+  LB = append([FN|RequiredArgs],RestNKeys,WholeMinusSymbol),
   PARAMS = [WholeMinusSymbol].
 
 % invoke([r1,r2,r3],RET).
-align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,_ArgInfo,PARAMS,wl:init_args(0,FN)):-
-  eval_uses_rest_only(FN),!,
-  LB = append(RequiredArgs,RestNKeys,WholeMinusSymbol),
-  PARAMS = [WholeMinusSymbol].   
+align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,_ArgInfo,PARAMS,wl:init_args(bind_parameters,FN)):-
+  eval_uses_whole(FN),!,
+  LB = append([FN|RequiredArgs],RestNKeys,WholeMinusSymbol),
+  PARAMS = [WholeMinusSymbol].
+
 
 % invoke(r1,r2,[o3,key1,value1],RET).
 align_args_local(FN,RequiredArgs,RestNKeys,WholeMinusSymbol,LB,ArgInfo,ArgsPlus,wl:init_args(N,FN)):- 
-  eval_uses_exact_and_restkeys(FN,N),!,
+  get_init_args(FN,N),number(N),!,
   RestNKeys = _,
   append(RequiredArgs,[RestNKeys],BetterArgs),
    (ArgInfo.whole == 0 -> LB = true ; LB = append(RequiredArgs,RestNKeys,WholeMinusSymbol)),
@@ -410,7 +411,7 @@
    expand_function_head(Ctx,Env,Symbol,FN,NewFormalParms,Whole,HeadParms,ZippedArgEnv,ArgInfo,HeadDefCode,HeadCode).
 
 
-
+/*
 % eval_uses_exact
 expand_function_head(Ctx,Env,Symbol,FN,FormalParms,Whole,HeadParms,ZippedArgEnv,ArgInfo, HeadDefCode,(HeadCode)):-
       Whole = [_|WholeMinusSymbol],
@@ -442,7 +443,7 @@
      must_bind_parameters(Env,Whole,RestNKeys,FormalParms,WholeMinusSymbol,Env,BindCode),
      always(BindCode)),
    HeadParms = [WholeMinusSymbol])).
-
+*/
 % align_args_local
 expand_function_head(Ctx,Env,Symbol,FN,FormalParms,Whole,HeadParms,ZippedArgEnv,ArgInfo, (HeadDefCode,assert_lsp(Symbol,Used)),
   HeadCodeOut):-

prolog/wam_cl/defgeneric.pl

@@ -19,9 +19,9 @@
 :- include('header').
 
 compile_genericfs(_Ctx,_Env,Symbol,[Function,Symbol,A2|AMORE],assert_lsp(Symbol,P)):- 
-   notrace(defgen(Function)),\+ is_defined(Function),!,P=..[Function,Symbol,A2,AMORE].
+   notrace(defgen(Function)),\+ is_implemented(Function),!,P=..[Function,Symbol,A2,AMORE].
 compile_genericfs(_Ctx,_Env,Symbol,[Fun0,Symbol,A2|AMORE],assert_lsp(Symbol,P)):- 
-   notrace((defgen(Function),same_symbol(Function,Fun0))),\+ is_defined(Function),!,P=..[Function,Symbol,A2,AMORE].
+   notrace((defgen(Function),same_symbol(Function,Fun0))),\+ is_implemented(Function),!,P=..[Function,Symbol,A2,AMORE].
 
 wl:init_args(2,X):- defgen(X).
 

prolog/wam_cl/funcall.pl

@@ -151,7 +151,7 @@
 
 compile_apply_function_or_macro_call(Ctx,Env,FN,Args,Result,ExpandedFunction):-
  always((
-   (is_list(Args)->length(Args,ArgsLen);true),
+   (is_list(Args)->length(Args,ArgsLen);(integer(Args)->ArgsLen=Args;true)),
    check_foc_operator(Ctx,Env,kw_function,FN,ArgsLen, ProposedName),!,
    align_args_or_fallback(Ctx,Env,FN, ProposedName,Args,Result,ArgsPlusResult),!,
    ExpandedFunction =.. [ ProposedName | ArgsPlusResult])),!.
@@ -166,7 +166,7 @@
   compile_apply1(Ctx,Env,F,Args,Result,ExpandedFunction),!.
 
 compile_apply1(Ctx,Env,F,Args,Result,ExpandedFunction):- atom(F),
- (eval_uses_exact_and_restkeys(F,N); ( F==list,N=0)),
+ ((get_init_args(F,N),integer(N)); ( F==list,N=0)),
  length(Left,N),
  append(Left,IntoList,Args),
  append(Left,[IntoList,Result],NewArgs),

prolog/wam_cl/groveler.pl

@@ -40,13 +40,20 @@
 
 wl:body_compiled(setq). 
 
+:- assertz(wl:interned_eval(call(define_body_compiled))).
+
+
+define_body_compiled:- forall(wl:body_compiled(Symbol),define_body_compiled(Symbol)).
+
+% TODO
+define_body_compiled(_Op). 
 
 
 
-was_pkg_prefix(sys,pkg_sys).
 was_pkg_prefix(sys,pkg_sys).
 was_pkg_prefix(u,pkg_user).
-was_pkg_prefix(clos,pkg_clos).
+was_pkg_prefix(clos,pkg_sys):- \+  current_prolog_flag(wamcl_pcl,true).
+was_pkg_prefix(clos,pkg_clos):- current_prolog_flag(wamcl_pcl,true).
 
 
 % grovel_system_symbols:-!.
@@ -106,33 +113,35 @@
   set_opv(Symbol,symbol_function,SF),
   set_opv(SF,type_of,sys_special_operator).
 
-:- assertz(wl:interned_eval(call(maplist(make_special_operator,[
-         block,
-         let_xx,
-         return_from,
-         catch,
-         load_time_value,
-         setq,
-         eval_when,
-         locally,
-         symbol_macrolet,
-         flet,
-         macrolet,
-         tagbody,
-         function,
-         multiple_value_call,
-         the,
-         go,
-         multiple_value_prog1,
-         throw,
-         if,
-         progn,
-         unwind_protect,
-         labels,
-         progv,
-         let,
-         quote])))).
-
+make_special_operator_symbols:- forall(cl_special_form(Symbol),make_special_operator(Symbol)).
+
+cl_special_form(block).
+cl_special_form(let_xx).
+cl_special_form(return_from).
+cl_special_form(catch).
+cl_special_form(load_time_value).
+cl_special_form(setq).
+cl_special_form(eval_when).
+cl_special_form(locally).
+cl_special_form(symbol_macrolet).
+cl_special_form(flet).
+cl_special_form(macrolet).
+cl_special_form(tagbody).
+cl_special_form(function).
+cl_special_form(multiple_value_call).
+cl_special_form(the).
+cl_special_form(go).
+cl_special_form(multiple_value_prog1).
+cl_special_form(throw).
+cl_special_form(if).
+cl_special_form(progn).
+cl_special_form(unwind_protect).
+cl_special_form(labels).
+cl_special_form(progv).
+cl_special_form(let).
+cl_special_form(quote).
+
+:- assertz(wl:interned_eval(call(make_special_operator_symbols))).
 
 :- fixup_exports.
 

prolog/wam_cl/header

@@ -192,6 +192,7 @@
 :- ensure_loaded(describe).
 :- ensure_loaded(disassemble).
 :- ensure_loaded(fileload).
+:- ensure_loaded(threading).
 :- ensure_loaded(funcall).
 
 :- ensure_loaded(defun).

prolog/wam_cl/mizepro.pl

@@ -201,7 +201,7 @@
 
 sanitize_true(_, C1,C2):- \+ compound(C1),!,C2=C1.
 sanitize_true(_, C1,C2):- non_compound_code(C1),!,C2=C1.
-sanitize_true(_,f_clos_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D.
+sanitize_true(_,f_sys_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D.
 sanitize_true(_,f_slot_value(A,B,C),get_opv(A,B,C)).
 sanitize_true(Ctx,(C1,C2),Joined):-!,sanitize_true(Ctx,C1,C1O),sanitize_true(Ctx,C2,C2O),conjoin_0(Ctx,C1O,C2O,Joined).
 sanitize_true(Ctx,(C2 ; CodeC),( C2O ; CodeCCO)):-!,sanitize_true(Ctx,C2,C2O),sanitize_true(Ctx,CodeC,CodeCCO).
@@ -511,7 +511,7 @@
 simple_inline(set_place(E, OP, N, V),set_var(E, N, V)):- var(V), atom(N),atom(OP),memberchk(OP,[psetq,setq]).
 %simple_inline(set_var(E, OP, [PLACE, N], V),set_place(E, OP, [PLACE, N], V)):- var(V), atom(N),atom(OP),memberchk(OP,[setf]).
 simple_inline(f_list(A,B),B=A).
-simple_inline(f_clos_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D.
+simple_inline(f_sys_pf_set_slot_value(A,B,C,D),set_slot(A,B,C)):-C=D.
 simple_inline(f_cdr(I,O),(I==[]->O=[];I=[_|O])):- wam_cl_option(debug,0).
 simple_inline(f_car(I,O),(I==[]->O=[];I=[O|_])):- wam_cl_option(debug,0).
 list_to_disj([C1],(C1O)):-!, list_to_disj(C1,C1O).

prolog/wam_cl/numbers.pl

@@ -136,7 +136,7 @@
 
 f_expt(N1,N2,Ret):- Ret is (N1 ^ N2).
 
-
+f_sys_random_posfixnum(Res):- Res is random(2147483647)+1.
 
 
 % asserting1... u

prolog/wam_cl/operatorfns.pl

@@ -139,28 +139,27 @@
   show_call_trace((generate_function_or_macro_name(Ctx,FN,BindType,ProposedName))),!.
 
 
-
-existing_operator(Ctx,Env,BindType,FN, _Len, ProposedName):-  show_success(get_symbol_fbounds(Ctx,Env,FN,BindType,ProposedName)),!.
-
-existing_operator(_Ctx,_Env,kw_function,FN,_Len, ProposedName):- get_opv(FN,symbol_function,ProposedName),
-   (latom_starts_with(ProposedName,'f_');latom_starts_with(ProposedName,'sf_')).
-existing_operator(_Ctx,_Env,kw_special,FN,_Len, ProposedName):- get_opv(FN,symbol_function,ProposedName),
-   (latom_starts_with(ProposedName,'f_');latom_starts_with(ProposedName,'sf_')).
-existing_operator(_Ctx,_Env,kw_macro,FN,_Len, ProposedName):- get_opv(FN,symbol_function,ProposedName),
-   (latom_starts_with(ProposedName,'mf_')).
-
-existing_operator(_Ctx,_Env,_,FN,_Len, ProposedName):- get_opv(FN,symbol_function,ProposedName),!.
-
+bind_type_naming(kw_function,FN,ProposedName):- (atom_concat('f_',FN,ProposedName);atom_concat('sf_',FN,ProposedName)),!.
+bind_type_naming(kw_special,FN,ProposedName):-  (atom_concat('sf_',FN,ProposedName);atom_concat('f_',FN,ProposedName)),!.
+bind_type_naming(kw_macro,FN,ProposedName):- atom_concat('mf_',FN,ProposedName).
+
+existing_operator(Ctx,Env,BindType,FN, _Len, ProposedName):- show_success(get_symbol_fbounds(Ctx,Env,FN,BindType,ProposedName)),!.
+existing_operator(_,_,BindType,FN,_, ProposedName):- get_opv(FN,symbol_function,ProposedName),bind_type_naming(BindType,_,ProposedName).
+existing_operator(_Ctx,_Env,BindType,FN,_Len, ProposedName):- bind_type_naming(BindType,FN,ProposedName),is_defined(ProposedName,_).
+%existing_operator(_Ctx,_Env,BindType,FN,_Len, ProposedName):- get_opv(FN,symbol_function,ProposedName),!,var(BindType).
+existing_operator(_Ctx,_Env,BindType,FN,_,ProposedName):- bind_type_naming(BindType,_,FN),ProposedName = FN.
 existing_operator(_Ctx,_Env,kw_function,FN,ArgsLen, ProposedName):- atom(FN),upcase_atom(FN,FN),
   (number(ArgsLen)-> Arity is ArgsLen+1; between(1,5,Arity)),is_defined(FN,Arity),ProposedName=FN.
 %existing_operator(_Ctx,_Env,kw_macro,FN,ArgsLen, ProposedName):- atom(FN),upcase_atom(FN,FN),                           
 %  (number(ArgsLen)-> Arity is ArgsLen+1; between(1,5,Arity)),is_defined(FN,Arity),ProposedName=FN.
 %existing_operator(_Ctx,_Env,_BindType,FN,_ArgLen, ProposedName):-some_defined_function_or_macro(FN,2,['mf_'],ProposedName),!.
-existing_operator(_Ctx,_Env,_BindType,FN,ArgLen, ProposedName):-some_defined_function_or_macro(FN,ArgLen,['sf_','f_'],ProposedName),!. % 'mf_'
-
-latom_starts_with(ProposedName,Start):- atom(ProposedName),atom_concat(Start,_,ProposedName).
+existing_operator(_Ctx,_Env,BindType,FN,ArgLen, ProposedName):-
+   some_defined_function_or_macro(FN,ArgLen,['sf_','f_','mf_'],ProposedName),!,
+   bind_type_naming(BindType,_,ProposedName). % 
 
 
+generate_function_or_macro_name(_Ctx,FN,BindType,ProposedName):-
+    bind_type_naming(BindType,_,FN),ProposedName = FN.
 
 generate_function_or_macro_name(Ctx,FN,BindType,NewProposedName):-
     maybe_symbol_package(FN,Package),
@@ -172,32 +171,32 @@
 
 eval_uses_env_arg1(F):- quietly((premute_names(F,FF),wl:declared(FF,env_arg1))).
 
-
-eval_uses_exact(F):- quietly((premute_names(F,FF),uses_exact0(FF))).
-
-uses_exact0(F):- wl:init_args(x,F),!.
-uses_exact0(FN):-  function_arg_info(FN,ArgInfo),!,
-   ArgInfo.complex==0,ArgInfo.opt==0,ArgInfo.rest==0,ArgInfo.env==0,ArgInfo.whole==0,
-   length(ArgInfo.names,NN),
-   arg_info_count(ArgInfo,req,N),!,
-   N==NN.
 
 
 function_arg_info(FN,ArgInfo):- wl:arglist_info(FN,_,_,ArgInfo).
 function_arg_info(FN,ArgInfo):- wl:arglist_info(FN,_,_,_,ArgInfo).
 function_arg_info(FN,ArgInfo):- wl:arglist_info(_,FN,_,_,ArgInfo).
 
 
-eval_uses_bind_parameters(F):- quietly((premute_names(F,FF), wl:init_args(bind_parameters,FF))),!.
+eval_uses_whole(F):- quietly((premute_names(F,FF), get_init_args(FF,while))),!.
+eval_bind_parameters(F):- quietly((premute_names(F,FF), get_init_args(FF,bind_parameters))),!.
+
+% get_init_args(FN,Requireds):- current_predicate(FN/N), Requireds is N-2,Requireds>0.
 
-% eval_uses_exact_and_restkeys(FN,Requireds):- current_predicate(FN/N), Requireds is N-2,Requireds>0.
+get_init_args(F,Args):- nonvar(Args),!,get_init_args(F,ArgsV),ArgsV=Args.
+get_init_args(F,N):- quietly((premute_names(F,FF), exact_and_restkeys(FF,N))),!.
 
-eval_uses_exact_and_restkeys(F,N):- quietly((premute_names(F,FF), exact_and_restkeys(FF,N))),!.
 
-exact_and_restkeys(F,N):- wl:init_args(V,F),integer(V),!,V=N.
-exact_and_restkeys(F,_):- uses_exact0(F),!,fail.
+exact_and_restkeys(F,N):- wl:init_args(N,F).
 exact_and_restkeys(F,N):- function_arg_info(F,ArgInfo),ArgInfo.req=L,ArgInfo.all\==L,!,arg_info_count(ArgInfo,req,N).
-exact_and_restkeys(F,0):- uses_rest_only0(F),!.
+exact_and_restkeys(F,0):- function_arg_info(F,ArgInfo),ArgInfo.req==0,ArgInfo.all\==0,!.
+exact_and_restkeys(F,0):- wl:declared(F,lambda(['&rest'|_])),!.
+exact_and_restkeys(FN,x):-  function_arg_info(FN,ArgInfo),!,
+   ArgInfo.complex==0,ArgInfo.opt==0,ArgInfo.rest==0,ArgInfo.env==0,ArgInfo.whole==0,
+   length(ArgInfo.names,NN),
+   arg_info_count(ArgInfo,req,N),!,
+   N==NN.
+
 
 arg_info_count(ArgInfo,Prop,N):- 
   Value=ArgInfo.Prop,
@@ -208,38 +207,29 @@
 
 premute_names(F,F).
 premute_names(F,FF):- atom_concat_or_rtrace('f_',F,FF).
-premute_names(F,FF):- atom_concat_or_rtrace('mf_',F,FF).
+% premute_names(F,FF):- atom_concat_or_rtrace('mf_',F,FF).
 premute_names(F,FF):- atom_concat_or_rtrace('sf_',F,FF).
 premute_names(F,FF):- atom_concat_or_rtrace('f_',FF,F).
-premute_names(F,FF):- atom_concat_or_rtrace('mf_',FF,F).
+% premute_names(F,FF):- atom_concat_or_rtrace('mf_',FF,F).
 premute_names(F,FF):- atom_concat_or_rtrace('sf_',FF,F).
 
-eval_uses_rest_only(F):- quietly((premute_names(F,FF),uses_rest_only0(FF))),!.
-
-uses_rest_only0(F):- wl:init_args(0,F),!.
-uses_rest_only0(F):- function_arg_info(F,ArgInfo),ArgInfo.req==0,ArgInfo.all\==0,!.
-%uses_rest_only0(F):- same_symbol(F,FF),wl:declared(FF,lambda(['&rest'|_])),!.
 
 % Non built-in function expands into an explicit function call
 
 % invoke(r1,r2,r3,RET).
 align_args(FN,ProposedName,Args,Result,ArgsPlusResult):- 
-  (eval_uses_exact(FN);eval_uses_exact(ProposedName)),
+  (get_init_args(FN,x);get_init_args(ProposedName,x)),
    append(Args, [Result], ArgsPlusResult).
 
 % invoke(r1,r2,[o3,key1,value1],RET).
 align_args(FN,ProposedName,Args,Result,ArgsPlusResult):- 
-  (eval_uses_exact_and_restkeys(FN,N);eval_uses_exact_and_restkeys(ProposedName,N)),
+  (get_init_args(FN,N);get_init_args(ProposedName,N)),number(N),
   always(length(Left,N)),append(Left,Rest,Args),
   append(Left, [Rest,Result], ArgsPlusResult).
 
-% invoke([r1,r2,r3],RET).
-align_args(FN,ProposedName,Args,Result,[Args,Result]):-
-  (eval_uses_rest_only(FN);eval_uses_rest_only(ProposedName)).
-
-% invoke([r1,r2,r3],RET).
-align_args(FN,ProposedName,Args,Result,[Args,Result]):-
-  (eval_uses_bind_parameters(FN);eval_uses_bind_parameters(ProposedName)).
+% invoke([fn,r1,r2,r3],RET).
+align_args(FN,ProposedName,Args,Result,[[FN|Args],Result]):-
+  (eval_uses_whole(FN);eval_uses_whole(ProposedName)).
 
 
 % guess invoke(r1,RET).
@@ -278,7 +268,10 @@
 is_defined(ProposedName,N):- integer(N),atom(ProposedName),!,functor(G,ProposedName,N),current_predicate(_,G),!.
 is_defined(ProposedName,N):- current_predicate(ProposedName/N).
 
-is_defined(FN):- is_fboundp(FN),foc_operator(_Ctx,_Env,_BindType,FN,_,ProposedName),is_defined(ProposedName,_).
+is_implemented(FN):- is_fboundp(FN),
+  foc_operator(_Ctx,_Env,_BindType,FN,_,ProposedName),  
+  ProposedName\==FN,is_defined(ProposedName,NN),!,
+  ((get_init_args(FN,N)->integer(N))->NN==N;true).
 
 maybe_symbol_package(Symbol,Package):-  get_opv(Symbol,symbol_package,Package),!.
 maybe_symbol_package(_Symbol,Package):- reading_package(Package).
@@ -299,7 +292,7 @@
 currently_visible_package(P):- reading_package(Package),
   (P=Package;package_use_list(Package,P)).
 
-is_lisp_operator(Ctx,Env,Sym):- get_symbol_fbounds(Ctx,Env,Sym,kw_special,_).
+is_lisp_operator(Ctx,Env,Sym):- get_symbol_fbounds(Ctx,Env,Sym,BindType,_),!,BindType\==kw_function.
 is_lisp_operator(_,_,G):- notrace(lisp_operator(G)).
 
 
@@ -314,9 +307,10 @@
 lisp_operator('define-variable-pattern').
 lisp_operator(u_define_caller_pattern).
 lisp_operator(f_u_define_caller_pattern).
+lisp_operator(S):- get_opv(S,symbol_function,FN),!, lisp_operator(FN).
 lisp_operator(S):- nonvar(S),compiler_macro_left_right(S,_,_).
 lisp_operator(S):- get_lambda_def(defmacro,S,_,_).
-lisp_operator(S):-is_special_op(S,P),currently_visible_package(P).
+lisp_operator(S):- is_special_op(S,P),currently_visible_package(P).
 %lisp_operator(S):-is_special_op(S,_P).
 
 get_lambda_def(DefType,ProcedureName,FormalParams,LambdaExpression):-