removing blob of programs into ../wam_common_lisp_devel_workspace

prolog/wam_cl/compile.pl

@@ -18,6 +18,9 @@
 :- module(comp, []).
 :- set_module(class(library)).
 :- include('./header').
+:- use_module(library(pce)).
+
+lisp_eval(SExpression):- lisp_compiled_eval(SExpression),!.
 
 lisp_compiled_eval(SExpression):-
   quietly(as_sexp_interned(SExpression,Expression)),

prolog/wam_cl/environs.pl

@@ -1,4 +1,4 @@
-/*******************************************************************
+/* ******************************************************************
  *
  * A Common Lisp compiler/interpretor, written in Prolog
  *
@@ -42,7 +42,7 @@
 
 set_el(O,Env,Name,Value):- HH=bv(Name,Value), H=[HH],ct(O,1,Env,H),ct(O,2,Env,H).
 
-/** PUSH-PREPEND-IF-NEW **/
+/* * PUSH-PREPEND-IF-NEW **/
 update_or_prepend(O,Env,Name,Value):- 
   Env=el(List,_) 
    -> (List==[]-> set_el(O,Env,Name,Value);update_lst_or_prepend(O,List,Name,Value))
@@ -52,7 +52,7 @@
   (ct(O,2,H,Value)->true;(T\==[],update_lst_or_prepend(O,T,Name,Value))),!.
 update_lst_or_prepend(O,Env,Name,Value):- Env=[H|T],!,ct(O,2,Env,[H|T]),ct(O,1,Env,bv(Name,Value)).
 
-/** PUSH-APPEND-IF-NEW **/
+/* * PUSH-APPEND-IF-NEW **/
 update_or_append(O,Env,Name,Value):- 
     Env=el(_,_) -> update_el_or_append(O,Env,Env,Name,Value); update_lst_or_append(O,Env,Name,Value).
 
@@ -71,13 +71,13 @@
 
 ct(O,N,P,E):- var(E) -> true ; call(O,N,P,E).
 
-/** PUSH-APPEND **/
+/* PUSH-APPEND */
 push_append(O,Env,Name,Value):- Env=el(_,_)->push_el_append(O,Env,Env,Name,Value);push_lst_append(O,Env,Name,Value).
 push_el_append(O,Env,el(_,[]),Name,Value):- set_el(O,Env,Name,Value).
 push_el_append(O,Env,el(_,Tail),Name,Value):- T=[bv(Name,Value)],ct(O,2,Tail,T),ct(O,2,Env,T).
 push_lst_append(O,Env,Name,Value):- Env=[_|T],(T==[]->(ct(O,2,Env,[bv(Name,Value)]));push_lst_append(O,T,Name,Value)).
 
-/** PUSH-PREPEND **/
+/* * PUSH-PREPEND **/
 push_prepend(O,Env,Name,Value):- Env=el(List,_)->push_le_prepend(O,Env,List,Name,Value);push_list_prepend(O,Env,Name,Value).
 
 push_le_prepend(O,Env,[],Name,Value):- !, set_el(O,Env,Name,Value).

prolog/wam_cl/places.pl

@@ -96,6 +96,49 @@
 is_place_op(incf).
 is_place_op(decf).
 /*
+
+(defun mapcar (f l)(cond ((null l) nil)(t (cons (funcall f (car l))(mapcar f (cdr l))))))
+(mapcar #'oddp '(1 2 3 4 5))
+(mapcar #'= '(1 2 3) '(3 2 1))
+
+
+(defun nconc (&optional lst &rest rest)
+  (if rest
+      (let ((rest-conc (apply #'nconc rest)))
+        (if (consp lst)
+            (progn (setf (cdr (last lst)) rest-conc)
+                   lst)
+            rest-conc))
+      lst))
+
+(defun mapcan (fn &rest lsts)
+  (apply #'nconc (apply #'mapcar fn lsts)))
+
+(mapcan #'(lambda (x) (and (numberp x) (list x)))
+          '(a 1 b c 3 4 d 5))
+
+(PRINT (permute '(A B Z) ) )
+
+(DEFUN permute (LIST)(IF LIST (MAPCAN #'(LAMBDA (x)(MAPCAR #'(LAMBDA (y)(CONS x y) )
+  (permute (REMOVE x LIST) ) ) ) LIST) '(NIL) ) )
+
+
+
+prolog.
+
+f_mapcan(Fn_In, RestNKeys, FnResult) :-
+        GEnv=[bv(u_fn, Fn_In), bv(u_lsts, Lsts_In)],
+        as_rest(u_lsts, Lsts_In, 0, RestNKeys),
+        catch(( ( get_var(GEnv, u_fn, Fn_Get),
+                  get_var(GEnv, u_lsts, Lsts_Get),
+                  f_apply(f_mapcar, [Fn_Get, Lsts_Get], Nconc_Param),
+                  f_nconc(Nconc_Param, Nconc_Ret)
+                ),
+                Nconc_Ret=FnResult
+              ),
+              block_exit(mapcan, FnResult),
+              true).
+
 is_place_op(rotatef).
 is_place_op(shiftf).
 

prolog/wam_cl/readtables.pl

@@ -176,8 +176,8 @@
 
 
 fix_symbols:-
-  forall(symbol_overlap(sys(pkg_cl,S1),sys(pkg_clos,S2)),move_symbol_into(S2,sys(pkg_cl))),
-  forall(symbol_overlap(sys(pkg_sys,S1),sys(pkg_sys,S2)),move_symbol_into(S1,sys(pkg_sys))),
+  forall(symbol_overlap(sys(pkg_cl,_S1),sys(pkg_clos,S2)),move_symbol_into(S2,sys(pkg_cl))),
+  forall(symbol_overlap(sys(pkg_sys,S1),sys(pkg_sys,_S2)),move_symbol_into(S1,sys(pkg_sys))),
   forall(symbol_in(int(pkg_cl,S1)),move_symbol_into(S1,sys(pkg_sys))),
   forall(symbol_in(sys(pkg_sys,S1)),move_symbol_into(S1,sys(pkg_sys))).
 

prolog/wam_cl/si.data

@@ -4132,29 +4132,29 @@ o_p_v(map_into,symbol_name,"MAP-INTO").
 o_p_v(map_into,symbol_package,pkg_cl).
 o_p_v(map_into,sys_call,t).
 o_p_v(map_into,type_of,symbol).
-o_p_v(mapc,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(mapc,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(mapc,ftype_result_type,list).
 o_p_v(mapc,symbol_function,f_mapc).
 o_p_v(mapc,symbol_name,"MAPC").
 o_p_v(mapc,symbol_package,pkg_cl).
 o_p_v(mapc,sys_call,t).
 o_p_v(mapc,sys_foldable,t).
 o_p_v(mapc,type_of,symbol).
-o_p_v(mapcan,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(mapcan,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(mapcan,ftype_result_type,t).
 o_p_v(mapcan,symbol_function,f_mapcan).
 o_p_v(mapcan,symbol_name,"MAPCAN").
 o_p_v(mapcan,symbol_package,pkg_cl).
 o_p_v(mapcan,sys_call,t).
 o_p_v(mapcan,type_of,symbol).
-o_p_v(mapcar,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(mapcar,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(mapcar,ftype_result_type,list).
 o_p_v(mapcar,symbol_function,f_mapcar).
 o_p_v(mapcar,symbol_name,"MAPCAR").
 o_p_v(mapcar,symbol_package,pkg_cl).
 o_p_v(mapcar,sys_call,t).
 o_p_v(mapcar,type_of,symbol).
-o_p_v(mapcon,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(mapcon,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(mapcon,ftype_result_type,t).
 o_p_v(mapcon,symbol_function,f_mapcon).
 o_p_v(mapcon,symbol_name,"MAPCON").
@@ -4169,15 +4169,15 @@ o_p_v(maphash,symbol_package,pkg_cl).
 o_p_v(maphash,sys_call,t).
 o_p_v(maphash,sys_flushable,t).
 o_p_v(maphash,type_of,symbol).
-o_p_v(mapl,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(mapl,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(mapl,ftype_result_type,list).
 o_p_v(mapl,symbol_function,f_mapl).
 o_p_v(mapl,symbol_name,"MAPL").
 o_p_v(mapl,symbol_package,pkg_cl).
 o_p_v(mapl,sys_call,t).
 o_p_v(mapl,sys_foldable,t).
 o_p_v(mapl,type_of,symbol).
-o_p_v(maplist,ftype_lambda_list,[sys_callable,list,c38_rest,list]).
+o_p_v(maplist,ftype_lambda_list,[sys_callable,c38_rest,list]).
 o_p_v(maplist,ftype_result_type,list).
 o_p_v(maplist,symbol_function,f_maplist).
 o_p_v(maplist,symbol_name,"MAPLIST").

prolog/wam_cl/socksrv.pl

@@ -72,13 +72,17 @@
     option(description(Desc),Options,Alias),
     dmsg(Port=Desc),
     thread_create(lsp_server_loop(ServerSocket, Options), _,
-                  [ alias(Alias)
-                  ]),!.
+                  [ alias(Alias),detached(true)]),!.
 
-resolve_host(Peer,Host):- catch(tcp_host_to_address(Host, Peer),_,fail),!.
-resolve_host(Peer,Host):- atom(Peer),Peer=Host,!.
-resolve_host(Peer,Host):- compound(Peer),catch((Peer=..PeerL,atomic_list_concat(PeerL,'.',Host)),_,fail),!.
-resolve_host(Peer,Host):- term_to_atom(Peer,Host),!.
+lsp_server_loop(ServerSocket, Options):-
+    ignore(catch(lsp_server_loop_1(ServerSocket, Options),E,writeln(user_error, lsp_server_loop_1(ServerSocket, Options,E)))),
+       lsp_server_loop(ServerSocket, Options).
+
+
+resolve_host_sksrv(Peer,Host):- catch(tcp_host_to_address(Host, Peer),_,fail),!.
+resolve_host_sksrv(Peer,Host):- atom(Peer),Peer=Host,!.
+resolve_host_sksrv(Peer,Host):- compound(Peer),catch((Peer=..PeerL,atomic_list_concat(PeerL,'.',Host)),_,fail),!.
+resolve_host_sksrv(Peer,Host):- term_to_atom(Peer,Host),!.
 
 
 
@@ -87,28 +91,19 @@
     tcp_accept(ServerSocket, ClientSock, Peer),
     tcp_open_socket(ClientSock, In, Out),
     set_stream(In, close_on_abort(false)),
-    set_stream(Out, close_on_abort(false)),
-
-
-    resolve_host(Peer,Host),
-    (   Postfix = []
-    ;   between(2, 1000, Num),
-        Postfix = [-, Num]
-    ),
+    set_stream(Out, close_on_abort(false)),    
+    resolve_host_sksrv(Peer,Host),
+    gensym('_',PostFix),
     option(alias(ServerAlias),Options,lspsrv_server),!,
-    atomic_list_concat(['client_',Host, '@', ServerAlias | Postfix], Alias),
+    atomic_list_concat(['client_',Host,PostFix, '@', ServerAlias], Alias),
     catch(thread_create(
               call_service_lsp_client(Host, Alias, ClientSock, In, Out, Peer, Options),
-              _,
-              [ alias(Alias),detached(true)
-              ]),
+              _, [ alias(Alias),detached(true)]),
           error(permission_error(create, thread, Alias), _),
           fail))).
 
 
-lsp_server_loop(ServerSocket, Options):-
-    ignore(catch(lsp_server_loop_1(ServerSocket, Options),E,writeln(user_error,E))),
-    lsp_server_loop(ServerSocket, Options).
+
 
 
 call_service_lsp_client(Host, Alias, ClientSock, In, Out, Peer, Options):-