/******************************************************************* * * A Common Lisp compiler/interpretor, written in Prolog * * (symbol_places.pl) * * * Douglas'' Notes: * * (c) Douglas Miles, 2017 * * The program is a *HUGE* common-lisp compiler/interpreter. It is written for YAP/SWI-Prolog . * *******************************************************************/ :- module(places, []). :- set_module(class(library)). :- include('header'). :- include('setf.pl'). % get_setf_expander_get_set_0_1(_Ctx,_Env,[car,Var],[car,Var],[set_car,Var], true):- atom(Var),!. %get_setf_expander_get_set_0_1(Ctx,Env,LVar,GET,[sys_set_symbol_value,GET], true):- atom(LVar),lookup_symbol_macro(Ctx,Env,LVar,GET),!. %get_setf_expander_get_set_0_1(_,_,LVar,GET,[set,GET], true):- \+ atom(LVar),atom(LVar),LVar=GET. f_clos_pf_set_slot_value(Obj,Key,Value,Value):- set_opv(Obj,Key,Value). lookup_symbol_macro(Ctx,Env,LVar,GET):- get_ctx_env_attribute(Ctx,Env,symbol_macro(LVar),GET). wl:init_args(1,cl_array_row_major_index). wl:init_args(exact_only,cl_row_major_aref). wl:setf_inverse(slot_value,clos_pf_set_slot_value). wl:setf_inverse(car,rplaca). wl:setf_inverse(cdr,rplacd). [defsetf, elt, u_set_elt], [defsetf, car, sys_set_car], [defsetf, u_pf_car, u_set_pf_car], [defsetf, first, sys_set_car], [defsetf, cdr, sys_set_cdr], [defsetf, u_pf_cdr, u_set_pf_cdr], [defsetf, rest, sys_set_cdr], [defsetf, u_uvref, u_uvset], [defsetf, aref, sys_aset], [defsetf, svref, sys_svset], [defsetf, u_pf_svref, u_pf_svset], [defsetf, char, sys_set_char], [defsetf, schar, sys_set_schar], [defsetf, u_pf_scharcode, u_pf_set_scharcode], [defsetf, symbol_value, set], [defsetf, symbol_plist, u_set_symbol_plist], [defsetf, fill_pointer, u_set_fill_pointer], %setf_inverse_op(Sym,Inv):- setf_inverse_op0(Sym,Inv),!. setf_inverse_op(Sym,Inverse):- setf_inverse_op0(Sym,Inv),listify(Inv,Inverse). setf_inverse_op0(Sym,Inverse):- wl:setf_inverse(Sym,Inverse). setf_inverse_op0(G,S):- notrace((cl_get(G,sys_setf_inverse,[],S),S\==[])),ground(S),!. setf_inverse_op0(Sym,Inverse):- symbol_prefix_and_atom(Sym,FunPkg,Name), member(SETPRefix,['setf','set','pf_set']), atomic_list_concat([FunPkg,SETPRefix,Name],'_',Inverse), find_lisp_function(Inverse,_Arity,_Fn),!. setf_inverse_op0(Sym,Inverse):- guess_setfs([setf,Sym],Inverse), find_lisp_function(Inverse,_Arity,_Fn). setf_inverse_op_forced(Sym,Inverse):- setf_inverse_op(Sym,Inverse),!. setf_inverse_op_forced(Sym,[sys_set_rslot,[quote,Sym]]). wl:interned_eval('`sys:set-rslot'). f_sys_set_rslot(Prop,Obj,Value,Res):- assertion((atom(Obj),atom(Prop))),set_opv(Obj,Prop,Value),Res=Value. /* get_setf_expander_get_set_0_1(Ctx,Env,[OP,LVar|EXTRA],[OP,GET|EXTRA],[INVERSE,GET|EXTRA], Body):- get_setf_expander_get_set_1_2(Ctx,Env,[OP,LVar|EXTRA],[OP,GET|EXTRA],[INVERSE,GET|EXTRA], (Code1, Body)):- compile_apply(Ctx,Env,OP,[LVar|EXTRA],Result,ExpandedFunction), ExpandedFunction=..[_FN|ARGS], append([VAR|PARAMS],[Result],ARGS), show_call_trace(( compile_each_quoted(Ctx,Env,PARAMS,CPARAMS,Code1), append([VAR|CPARAMS],[_VAL,Result],_SETFARGS), setf_inverse_op(OP,INVERSE))), must_compile_body(Ctx,Env,GET,LVar, Body), (var(GET)->put_attr(GET,preserved_var,t); true). make_place_op(Ctx,Env,Result,incf,GET,LV,SET,Body) :- always(( value_or(LV,Value,1),!, must_compile_body(Ctx,Env,ValueR,Value,Part1), must_compile_body(Ctx,Env,Old,GET,Part2), Part3 = (New is Old+ ValueR), append(SET,[New],LispOp), must_compile_body(Ctx,Env,Result,LispOp,Part4), Body = (Part1,Part2,Part3,Part4))). */ is_setf_op([setf|Accessor],Accessor):- nonvar(Accessor). not_place_op(setq). not_place_op(psetq). is_parallel_op(psetf). is_parallel_op(psetq). is_pair_op(X):- is_setf_or_setq(X). is_only_read_op(_):- fail. is_place_op(setf). is_place_op(psetf). %is_place_op(incf). is_place_op(decf). /* is_place_op(rotatef). is_place_op(shiftf). (defmacro rotatef (&rest args) `(psetf ,@(mapcan #'list args (append (cdr args) (list (car args)))))) not place ops but now Macros is_place_op(push). is_place_op(pushnew). is_place_op(pop). */ pairify([],[],[]). pairify([Var, ValueForm | Rest],[Var | Atoms],[ValueForm | Forms]):- pairify(Rest,Atoms,Forms). combine_setfs(Name0,Name):-atom(Name0),!,Name0=Name. combine_setfs([Setf,Name],Combined):- cl_symbol_package(Name,Pkg),pl_symbol_name(Setf,SetfStr),pl_symbol_name(Name,NameStr),atomics_to_string([SetfStr,NameStr],"-",SETF_STR), string_upper(SETF_STR,UPPER_SETF_STR), cl_intern(UPPER_SETF_STR,Pkg,Combined). guess_setfs([Setf,Name],Combined):- cl_symbol_package(Name,Pkg),pl_symbol_name(Setf,SetfStr),pl_symbol_name(Name,NameStr),atomics_to_string([SetfStr,NameStr],"-",SETF_STR), string_upper(SETF_STR,UPPER_SETF_STR), package_find_symbol(UPPER_SETF_STR,Pkg,Combined,_IntExt). %combine_setfs([setf,Name],Combined):- atomic_list_concat([setf,Name],'_',Combined). compile_accessors(_Ctx,_Env,_Result,[SetQ|_], _Body):- var(SetQ),!,fail. compile_accessors(Ctx,Env,Result,[SetQ, Var, ValueForm, Atom2| Rest], Body):- is_parallel_op(SetQ),!, pairify([Var, ValueForm, Atom2| Rest],Atoms,Forms), compile_each_quoted(Ctx,Env,Results,Forms,BodyS1), maplist(set_with_prolog_var(Ctx,Env,SetQ),Atoms,Results,BodyS2), ((op_return_type(SetQ,RT),RT=name) -> last(Atoms,Result) ; last(Results,Result)), append(BodyS1,BodyS2,BodyS),list_to_conjuncts(BodyS,Body). compile_accessors(Ctx,Env,Result,[SetQ, Var, ValueForm, Atom2| Rest], Body):- is_pair_op(SetQ), !, must_compile_body(Ctx,Env,_ResultU,[SetQ, Var, ValueForm], Body1), must_compile_body(Ctx,Env,Result,[SetQ, Atom2| Rest], Body2), Body = (Body1 , Body2). compile_accessors(Ctx,Env,Result,[Defvar, Var], Body):- is_def_nil(Defvar),!, must_compile_body(Ctx,Env,Result,[Defvar, Var , []],Body). compile_accessors(Ctx,Env,Result,[INCF,Var|Params], Body):- is_place_op(INCF),!, % this includes SETF itself always(compile_place_operation(Ctx,Env,Result,[INCF,Var|Params], Body)). /* compile_accessors(Ctx,Env,Result,[GETF,Var|Params], Body):- is_place_accessor(GETF),!, always(compile_place_accessor(Ctx,Env,Result,[GETF,Var|Params], Body)). is_place_accessor(GETF):- \+ is_place_op(GETF),fail. compile_place_accessor(Ctx,Env,Result,[AREF,Var|Params], Body):- must_compile_body(Ctx,Env,Result,[AREF,Var|Params], Body) */ is_setf_or_setq(CL_SETQ):- \+ atom(CL_SETQ),!,fail. is_setf_or_setq(CL_SETQ):- is_setf_or_setq0(CL_SETQ),!. is_setf_or_setq(CL_SETQ):- atom_concat('cl_',Root,CL_SETQ),!,is_setf_or_setq0(Root). is_setf_or_setq0(psetf). is_setf_or_setq0(psetq). is_setf_or_setq0(setf). is_setf_or_setq0(setq). set_with_prolog_var(Ctx,Env,PSetQ,Var,Result,set_var(Env, Var, Result)):- assertion(is_setf_or_setq(PSetQ)),!, assertion(atom(Var)),rw_add(Ctx,Var,w). set_with_prolog_var(Ctx,Env,SetQ,Var,Result,set_var4(Env,SetQ, Var, Result)):- rw_add(Ctx,Var,w). atom_or_var(Atom):- var(Atom) ; atom(Atom). :- discontiguous compile_accessors/5. /* TODO CONFIRM WE ARE SETTING SYMBOLS honoring SYMBOL-MACROs */ compile_place_operation(Ctx,Env,Result,[SETF, LVar, ValueForm], Code):- is_setf_or_setq(SETF), lookup_symbol_macro(Ctx,Env,LVar,SET), LVar\==SET,!, rw_add(Ctx,LVar,r), must_compile_body(Ctx,Env,Result,[SETF, SET, ValueForm],Code). compile_place_operation(Ctx,Env,Result,[SETQ, Symbol, ValueForm], Body):- is_setf_or_setq(SETQ), atom(Symbol),!, assertion(is_symbolp(Symbol)), rw_add(Ctx,Symbol,w), must_compile_body(Ctx,Env,ValueResult,ValueForm,Part1), Result = ValueResult, set_with_prolog_var(Ctx,Env,SETQ,Symbol,ValueResult,Part2), Body = (Part1, Part2). compile_place_operation(Ctx,Env,Value,[setf,Place,ValueForm], Body):- assertion(nonvar(Place)), Place = [AREF,Symbol|Indexes], setf_inverse_op_forced(AREF,SETAREF),!, compile_each_quoted(Ctx,Env,RIndexes,Indexes,Part1), must_compile_body(Ctx,Env,Value,ValueForm,Part2), append([SETAREF,[Symbol],RIndexes,[Value]],Compile3), must_compile_body(Ctx,Env,_,Compile3,Part3), Body = (Part1,Part2,Part3). /* compile_place_operation(Ctx,Env,IncfResult,[INCF,Symbol|ValuesForm], Body):- atom_or_var(Symbol), get_setf_expansion compile_each_quoted(Ctx,Env,RIndexes,Indexes,Part1), must_compile_body(Ctx,Env,Old,[AREF,Symbol|RIndexes],Part2), compile_each_quoted(Ctx,Env,RValues,ValuesForm,Part3), must_compile_body(Ctx,Env,IncfResult,[INCF,Old|RValues],Part4), append([SETAREF,[Symbol],RIndexes,RValues],Compile5), must_compile_body(Ctx,Env,_,Compile5,Part5), Body = (Part1,Part2,Part3,Part4,Part5). */ compile_place_operation(Ctx,Env,IncfResult,[INCF,Nonvar|ValuesForm], Body):- nonvar(Nonvar),Nonvar=[AREF,Symbol|Indexes], atom_or_var(Symbol), setf_inverse_op_forced(AREF,SETAREF),!, compile_each_quoted(Ctx,Env,RIndexes,Indexes,Part1), must_compile_body(Ctx,Env,Old,[AREF,Symbol|RIndexes],Part2), compile_each_quoted(Ctx,Env,RValues,ValuesForm,Part3), must_compile_body(Ctx,Env,IncfResult,[INCF,Old|RValues],Part4), append([SETAREF,[Symbol],RIndexes,RValues],Compile5), must_compile_body(Ctx,Env,_,Compile5,Part5), Body = (Part1,Part2,Part3,Part4,Part5). compile_place_operation(Ctx,Env,IncfResult,[INCF,Nonvar|ValuesForm], Body):- % nonvar(Nonvar), Nonvar=[AREF,Place|Indexes], assertion(is_list(Place)), %Place=[_CAR,_Symbol|_CarArgs], % atom(Symbol), setf_inverse_op_forced(AREF,SETAREF), %slow_trace,setf_inverse_op(CAR,SETCAR),!, must_compile_body(Ctx,Env,SymbolCar,Place,Part1), compile_each_quoted(Ctx,Env,RIndexes,Indexes,Part2), must_compile_body(Ctx,Env,Old,[AREF,SymbolCar|RIndexes],Part3), compile_each_quoted(Ctx,Env,RValues,ValuesForm,Part4), must_compile_body(Ctx,Env,IncfResult,[INCF,Old|RValues],Part5), append([SETAREF,[SymbolCar],RIndexes,RValues],Compile6), must_compile_body(Ctx,Env,_,Compile6,Part6), %append([SETCAR,[Symbol],[[AREF,SymbolCar|RIndexes]]],Compile7), %must_compile_body(Ctx,Env,_,Compile7,Part7), Body = (Part1,Part2,Part3,Part4,Part5,Part6). /* compile_accessors(Ctx,Env,Result,[Getf|ValuePlace], Body):- fail, is_place_op_verbatum(Getf), fail,fail,fail,fail, % Just so i finanly notice! debug_var([Getf,'_R'],Result), debug_var([Getf,'_Env'],Env), place_extract(ValuePlace,Value,Place), extract_var_atom(Place,RVar), (is_only_read_op(Getf)->rw_add(Ctx,RVar,r);rw_add(Ctx,RVar,w)), Body = (set_place(Env,Getf, Place, Value, Result)). */ extract_var_atom([_,RVar|_],RVar):-atomic(RVar). extract_var_atom(Var,Var). % % (LET ((a 0)(v (VECTOR 0 1 2 3 4 5))) (INCF (AREF (INCF a))) v) % % (LET ((a 0)(v (VECTOR 0 1 2 3 4 5))) (INCF (AREF (INCF a))) v) % compile_place(Ctx,Env,Result,Var,Code). compile_place(_Ctx,_Env,[value,Var],Var,true):- \+ is_list(Var),!. %compile_place(_Ctx,_Env,[Place,Var],[Place,Var],true):- atom(Var),!. compile_place(Ctx,Env,[Place|VarResult],[Place|VarEval],Code):- compile_each_quoted(Ctx,Env,VarResult,VarEval,Code). %compile_place(Ctx,Env,[Place,Var,Result],[Place,Var|Eval],Code):- must_compile_progn(Ctx,Env,Result,Eval,Code). %compile_place(_Ctx,_Env,Var,Var,true). wl:interned_eval_e( "(defmacro pushnew (obj place) (let ((sym (gensym))) `(let ((,sym ,obj)) (unless (member ,sym ,place) (push ,sym ,place)))))"). %(wl:init_args(2,cl_pushnew)). %cl_pushnew(Element, Place, FnResult) :- wl:interned_eval_e( '(defmacro my-push (element place) (let ((el-sym (gensym)) (new-sym (gensym "NEW"))) `(let* ((,el-sym ,element) (,new-sym (cons ,el-sym ,place))) (setf ,place ,new-sym)))))'). cl_push(Element, Place, FnResult) :- global_env(ReplEnv), Env=[bv(u_element, Element), bv(u_place, Place)|ReplEnv], cl_gensym(El_sym_Init), cl_gensym('$ARRAY'([*], claz_base_character, "NEW"), New_sym_Init), LEnv=[bv(u_el_sym, El_sym_Init), bv(u_new_sym, New_sym_Init)|Env], get_var(LEnv, u_el_sym, El_sym_Get12), get_var(LEnv, u_element, Element_Get), get_var(LEnv, u_new_sym, New_sym_Get15), get_var(LEnv, u_place, Place_Get14), [let_xx, [[El_sym_Get12, Element_Get], [New_sym_Get15, [cons, El_sym_Get12, Place_Get14]]], [setf, Place_Get14, New_sym_Get15]]=MFResult, cl_eval(MFResult, FnResult). /* (defun setf-function-name-p (name) (and (consp name) (consp (%cdr name)) (null (%cddr name)) (symbolp (%cadr name)) (eq (car name) 'setf))) */ % asserting... u wl:arglist_info(f_sys_setf_function_name_p, [sys_name], [_Name_Param], arginfo{all:[sys_name], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[sys_name], opt:0, req:[sys_name], rest:0, whole:0}). % asserting... u wl:init_args(exact_only, f_sys_setf_function_name_p). % asserting... u wl:lambda_def(defun, sys_setf_function_name_p, f_sys_setf_function_name_p, [sys_name], [[and, [consp, sys_name], [consp, [ext_pf_cdr, sys_name]], [null, [u_pf_cddr, sys_name]], [symbolp, [ext_pf_cadr, sys_name]], [eq, [car, sys_name], [quote, setf]]]]). f_sys_setf_function_name_p(Name_Param, TrueResult66) :- ( is_consp(Name_Param) -> f_ext_pf_cdr(Name_Param, PredArgResult35), ( is_consp(PredArgResult35) -> f_u_pf_cddr(Name_Param, IFTEST40), ( IFTEST40==[] -> f_ext_pf_cadr(Name_Param, PredArgResult53), ( is_symbolp(PredArgResult53) -> cl_car(Name_Param, Is_eq_Param), t_or_nil(is_eq(Is_eq_Param, setf), TrueResult), TrueResult66=TrueResult ; TrueResult66=[] ) ; TrueResult66=[] ) ; TrueResult66=[] ) ; TrueResult66=[] ). value_or([Value],Value,_):- !. value_or([],Value,Value):- !. value_or(Value,Value,_). wl:init_args(1,cl_get_setf_expansion). %place_op(Env,PlOP,[Place,Obj],[],Result):- place_op(Env,PlOP,Obj,[Place],Result). %place_op(Env,PlOP,Obj,Value,Result):- var(Env),ensure_env(Env), \+ var(Env),!, place_op(Env,PlOP,Obj,Value,Result). to_place([value,Obj],Obj,value):-!. to_place([symbol_value,Obj],Obj,value):-!. to_place([slot_value,Obj,Place],Obj,Place):-!. to_place([AREF,Obj|Index],Obj,[AREF|Index]):-!. to_place([Place,Obj],Obj,Place):-!. to_place([Place,Obj|Args],Obj,[Place|Args]):-!. %to_place([Obj],Obj,value):-!. to_place(Obj,Obj,value). get_place(Env, Oper, Obj, Value, Result):- always(to_place(Obj,RObj,Place)),!, always(place_op(Env, Oper, RObj, Place, Value, Result)). set_place(Env, Oper, Obj, Value, Result):- always(to_place(Obj,RObj,Place)),!, always(place_op(Env, Oper, RObj, Place, Value, Result)). plistify(L,L):-L==[],!. plistify([H|T],[H|T]):-!. plistify(H,[H]). place_op(Env,getf,Obj,Place,[Value],Value):-!,get_place_value(Env, Obj, Place, Value). place_op(Env,setf,Obj,Place, [Value], Value):-!,set_place_value(Env, Obj, Place, Value). place_op(Env,incf, Obj, Place, LV, Result):- value_or(LV,Value,1),!, get_place_value(Env, Obj, Place, Old), Result is Old+ Value, set_place_value(Env, Obj, Place, Result). place_op(Env,decf, Obj, Place, LV, Result):- value_or(LV,Value,1),!, get_place_value(Env, Obj, Place, Old), Result is Old- Value, set_place_value(Env, Obj, Place, Result). place_op(Env,pop, Obj, Place, [], Result):- get_place_value(Env, Obj, Place, Old), plistify(Old,OldL), (OldL = [Result|New]-> true ; (Old=[],New=[],Result=[])), set_place_value(Env, Obj, Place, New). place_op(Env,pushnew, Obj, Place, LV, Result):- value_or(LV,Value,[]),!, get_place_value(Env, Obj, Place, Old), plistify(Old,OldL), Result = [Value|OldL], set_place_value(Env, Obj, Place, Result). place_extract([Value,Place],[Value],Place). place_extract([Place],[],Place). place_extract([Value|Place],Value,Place). get_place_value(_,[H|_],car,H). get_place_value(_,[_|T],cdr,T). get_place_value(Env, Obj, value, Value):- atom(Obj),!,get_symbol_value(Env,Obj,Value). get_place_value(_Env, Obj, Place, Value):- get_opv(Obj, Place, Value). set_place_value(_,Cons,car,H):- is_consp(Cons),!, cl_rplaca(Cons,H,_). set_place_value(_,Cons,cdr,T):- is_consp(Cons),!, cl_rplacd(Cons,T,_). set_place_value(Env, Obj, value, Value):- atom(Obj),!,set_var(Env,Obj,Value). set_place_value(_Env, Obj, Place, Value):- set_opv(Obj, Place, Value). %with_place_value(Env,OPR,Obj,Place, Value):-!, type_or_class_nameof(Obj,Type),with_place_value(Env,OPR,Obj,Type,Place,Value). /* with_place_value(Env,OPR,Obj,Type,Place,Value):- always(atomic_list_concat(List,'_',Place)), with_place_value6(Env,OPR,Place,List,Type,Obj,Value). with_place_value6(_Env,OPR,_Place,[Type,Prop],Type,Obj, Value):- call_opv(OPR,Obj,Prop,Value),!. with_place_value6(_Env,OPR, Place,_List, _Type,Obj, Value):- call_opv(OPR,Obj,Place,Value),!. call_opv(OPR,[slot_value,Obj,Place],value,Value):- !, call(OPR,Obj,Place,Value). call_opv(OPR,[Place,Obj],value,Value):- !, call(OPR,Obj,Place,Value). call_opv(OPR,Obj,Place,Value):- !, call(OPR,Obj,Place,Value). */ /* The effect of (defsetf symbol-value set) is built into the Common Lisp system. This causes the form (setf (symbol-value foo) fu) to expand into (set foo fu). Note that (defsetf car rplaca) would be incorrect because rplaca does not return its last argument. */ :- fixup_exports. end_of_file. (get-setf-expansion '(symbol-value 't)) (#:TEMP-5499) ; ('T) ; (#:NEW-5498) ; (SYSTEM::SET-SYMBOL-VALUE #:TEMP-5499 #:NEW-5498) ; (SYMBOL-VALUE #:TEMP-5499) (get-setf-expansion (symbol-value 't)) NIL ; NIL ; (#:NEW-3230) ; (SETQ T #:NEW-3230) ; Examples: (defun lastguy (x) (car (last x)) => LASTGUY (define-setf-expander lastguy (x &environment env) "Set the last element in a list to the given value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-expansion x env) (let ((store (gensym))) (values dummies vals `(,store) `(progn (rplaca (last ,getter) ,store) ,store) `(lastguy ,getter))))) => LASTGUY (setq a (list 'a 'b 'c 'd) b (list 'x) c (list 1 2 3 (list 4 5 6))) => (1 2 3 (4 5 6)) (setf (lastguy a) 3) => 3 (setf (lastguy b) 7) => 7 (setf (lastguy (lastguy c)) 'lastguy-symbol) => LASTGUY-SYMBOL a => (A B C 3) b => (7) c => (1 2 3 (4 5 LASTGUY-SYMBOL)) ;;; Setf expander for the form (LDB bytespec int). ;;; Recall that the int form must itself be suitable for SETF. (define-setf-expander ldb (bytespec int &environment env) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-expansion int env);Get setf expansion for int. (let ((btemp (gensym)) ;Temp var for byte specifier. (store (gensym)) ;Temp var for byte to store. (stemp (first stores))) ;Temp var for int to store. (if (cdr stores) (error "Can't expand this.")) ;;; Return the setf expansion for LDB as five values. (values (cons btemp temps) ;Temporary variables. (cons bytespec vals) ;Value forms. (list store) ;Store variables. `(let ((,stemp (dpb ,store ,btemp ,access-form))) ,store-form ,store) ;Storing form. `(ldb ,btemp ,access-form) ;Accessing form. )))) Affected By: None.