1#!/usr/bin/env swipl
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;;; Exporting external symbols of LISP package
40*/
41/*
42(si::select-package "CL")
43
44*/
45
46/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:510 **********************/
47:-lisp_compile_to_prolog(pkg_user,['si::select-package','$STRING'("CL")])
48:- f_sys_select_package('$ARRAY'([*], claz_base_character, "CL"), _Ignored).
49/*
50(export '(
51 &whole
52 &environment
53 &body
54 *
55 **
56 ***
57 *break-enable*
58 *break-on-warnings*
59 *features*
60 *modules*
61 +
62 ++
63 +++
64 -
65 /
66 //
67 ///
68 COMMON
69 KYOTO
70 KCL
71 ECL
72 abs
73 acos
74 acosh
75 adjust-array
76 adjustable-array-p
77 apropos
78 apropos-list
79 arglist
80 array-dimension
81 array-dimensions
82 array-element-type
83 array-has-fill-pointer-p
84 array-in-bounds-p
85 array-rank
86 array-row-major-index
87 asin
88 asinh
89 assert
90 atanh
91 bit
92 bit-and
93 bit-andc1
94 bit-andc2
95 bit-eqv
96 bit-ior
97 bit-nand
98 bit-nor
99 bit-not
100 bit-orc1
101 bit-orc2
102 bit-xor
103 break
104 byte
105 byte-position
106 byte-size
107 ccase
108 cerror
109 check-type
110 cis
111 coerce
112 compile
113 compile-file
114 concatenate
115 cosh
116 count
117 count-if
118 count-if-not
119 ctypecase
120 decf
121 decode-universal-time
122 defconstant
123 define-modify-macro
124 define-setf-method
125 defparameter
126 defsetf
127 defstruct
128 deftype
129 defvar
130 delete
131 delete-duplicates
132 delete-if
133 delete-if-not
134 deposit-field
135 describe
136 disassemble
137 do*
138 do-all-symbols
139 do-external-symbols
140 do-symbols
141 documentation
142 dolist
143 dotimes
144 dpb
145 dribble
146 ecase
147 ed
148 eighth
149 encode-universal-time
150 error
151 etypecase
152 eval-when
153 every
154 fceiling
155 ffloor
156 fifth
157 fill
158 fill-pointer
159 find
160 find-all-symbols
161 find-if
162 find-if-not
163 first
164 format
165 fourth
166 fround
167 ftruncate
168 get-decoded-time
169 get-setf-method
170 get-setf-method-multiple-value
171 get-universal-time
172 getf
173 ignore
174 incf
175 inspect
176 intersection
177 isqrt
178 ldb
179 ldb-test
180 lisp-implementation-type
181 logandc1
182 logandc2
183 lognand
184 lognor
185 lognot
186 logorc1
187 logorc2
188 logtest
189 long-site-name
190 loop
191 machine-instance
192 machine-type
193 machine-version
194 make-array
195 make-sequence
196 map
197 mask-field
198 merge
199 mismatch
200 mod
201 multiple-value-setq
202 nintersection
203 ninth
204 notany
205 notevery
206 nset-difference
207 nset-exclusive-or
208 nsubstitute
209 nsubstitute-if
210 nsubstitute-if-not
211 nunion
212 phase
213 pop
214 position
215 position-if
216 position-if-not
217 prin1-to-string
218 princ-to-string
219 prog*
220 provide
221 psetf
222 push
223 pushnew
224 rational
225 rationalize
226 read-from-string
227 reduce
228 rem
229 remf
230 remove
231 remove-duplicates
232 remove-if
233 remove-if-not
234 replace
235 require
236 rotatef
237 room
238 sbit
239 search
240 second
241 set-difference
242 set-exclusive-or
243 setf
244 seventh
245 shiftf
246 short-site-name
247 signum
248 sinh
249 sixth
250 software-type
251 software-version
252 some
253 sort
254 stable-sort
255 step
256 structure
257 subsetp
258 substitute
259 substitute-if
260 substitute-if-not
261 subtypep
262 tanh
263 tenth
264 third
265 time
266 trace
267 type
268 typecase
269 typep
270 union
271 untrace
272 variable
273 vector
274 vector-pop
275 vector-push
276 vector-push-extend
277 warn
278 with-input-from-string
279 with-open-file
280 with-open-stream
281 with-output-to-string
282 write-to-string
283 y-or-n-p
284 yes-or-no-p
285
286 proclaim
287 proclamation
288 special
289 type
290 ftype
291 function
292 inline
293 notinline
294 ignore
295 optimize
296 speed
297 space
298 safety
299 compilation-speed
300 declaration
301
302 *eval-when-compile*
303
304 clines
305 defcfun
306 defentry
307 defla
308 defcbody ; Beppe
309 definline ; Beppe
310 defunC ; Beppe
311 void
312 object
313 char* ; Beppe
314 char
315 int
316 float
317 double
318 ))
319
320;;; ----------------------------------------------------------------------
321;;;
322*/
323
324/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:538 **********************/
325:-lisp_compile_to_prolog(pkg_cl,[export,[quote,['&whole','&environment','&body',*,**,***,'*break-enable*','*break-on-warnings*','*features*','*modules*',+,++,+++,-,/,//,///,'COMMON','KYOTO','KCL','ECL',abs,acos,acosh,'adjust-array','adjustable-array-p',apropos,'apropos-list',arglist,'array-dimension','array-dimensions','array-element-type','array-has-fill-pointer-p','array-in-bounds-p','array-rank','array-row-major-index',asin,asinh,assert,atanh,bit,'bit-and','bit-andc1','bit-andc2','bit-eqv','bit-ior','bit-nand','bit-nor','bit-not','bit-orc1','bit-orc2','bit-xor',break,byte,'byte-position','byte-size',ccase,cerror,'check-type',cis,coerce,compile,'compile-file',concatenate,cosh,count,'count-if','count-if-not',ctypecase,decf,'decode-universal-time',defconstant,'define-modify-macro','define-setf-method',defparameter,defsetf,defstruct,deftype,defvar,delete,'delete-duplicates','delete-if','delete-if-not','deposit-field',describe,disassemble,'do*','do-all-symbols','do-external-symbols','do-symbols',documentation,dolist,dotimes,dpb,dribble,ecase,ed,eighth,'encode-universal-time',error,etypecase,'eval-when',every,fceiling,ffloor,fifth,fill,'fill-pointer',find,'find-all-symbols','find-if','find-if-not',first,format,fourth,fround,ftruncate,'get-decoded-time','get-setf-method','get-setf-method-multiple-value','get-universal-time',getf,ignore,incf,inspect,intersection,isqrt,ldb,'ldb-test','lisp-implementation-type',logandc1,logandc2,lognand,lognor,lognot,logorc1,logorc2,logtest,'long-site-name',loop,'machine-instance','machine-type','machine-version','make-array','make-sequence',map,'mask-field',merge,mismatch,mod,'multiple-value-setq',nintersection,ninth,notany,notevery,'nset-difference','nset-exclusive-or',nsubstitute,'nsubstitute-if','nsubstitute-if-not',nunion,phase,pop,position,'position-if','position-if-not','prin1-to-string','princ-to-string','prog*',provide,psetf,push,pushnew,rational,rationalize,'read-from-string',reduce,rem,remf,remove,'remove-duplicates','remove-if','remove-if-not',replace,require,rotatef,room,sbit,search,second,'set-difference','set-exclusive-or',setf,seventh,shiftf,'short-site-name',signum,sinh,sixth,'software-type','software-version',some,sort,'stable-sort',step,structure,subsetp,substitute,'substitute-if','substitute-if-not',subtypep,tanh,tenth,third,time,trace,type,typecase,typep,union,untrace,variable,vector,'vector-pop','vector-push','vector-push-extend',warn,'with-input-from-string','with-open-file','with-open-stream','with-output-to-string','write-to-string','y-or-n-p','yes-or-no-p',proclaim,proclamation,special,type,ftype,function,inline,notinline,ignore,optimize,speed,space,safety,'compilation-speed',declaration,'*eval-when-compile*',clines,defcfun,defentry,defla,defcbody,definline,defunC,void,object,'char*',char,int,float,double]]])
326:- f_export(
327 [ c38_whole,
328 c38_environment,
329 c38_body,
330 (*),
331 (**),
332 ***,
333 xx_break_enable_xx,
334 sys_xx_break_on_warnings_xx,
335 xx_features_xx,
336 xx_modules_xx,
337 (+),
338 ++,
339 +++,
340 (-),
341 (/),
342 (//),
343 ///,
344 common,
345 kyoto,
346 kcl,
347 ecl,
348 abs,
349 acos,
350 acosh,
351 adjust_array,
352 adjustable_array_p,
353 apropos,
354 apropos_list,
355 sys_arglist,
356 array_dimension,
357 array_dimensions,
358 array_element_type,
359 array_has_fill_pointer_p,
360 array_in_bounds_p,
361 array_rank,
362 array_row_major_index,
363 asin,
364 asinh,
365 assert,
366 atanh,
367 bit,
368 bit_and,
369 bit_andc1,
370 bit_andc2,
371 bit_eqv,
372 bit_ior,
373 bit_nand,
374 bit_nor,
375 bit_not,
376 bit_orc1,
377 bit_orc2,
378 bit_xor,
379 break,
380 byte,
381 byte_position,
382 byte_size,
383 ccase,
384 cerror,
385 check_type,
386 cis,
387 coerce,
388 compile,
389 compile_file,
390 concatenate,
391 cosh,
392 count,
393 count_if,
394 count_if_not,
395 ctypecase,
396 decf,
397 decode_universal_time,
398 defconstant,
399 define_modify_macro,
400 sys_define_setf_method,
401 defparameter,
402 defsetf,
403 defstruct,
404 deftype,
405 defvar,
406 delete,
407 delete_duplicates,
408 delete_if,
409 delete_if_not,
410 deposit_field,
411 describe,
412 disassemble,
413 do_xx,
414 do_all_symbols,
415 do_external_symbols,
416 do_symbols,
417 documentation,
418 dolist,
419 dotimes,
420 dpb,
421 dribble,
422 ecase,
423 ed,
424 eighth,
425 encode_universal_time,
426 error,
427 etypecase,
428 eval_when,
429 every,
430 fceiling,
431 ffloor,
432 fifth,
433 fill,
434 fill_pointer,
435 find,
436 find_all_symbols,
437 find_if,
438 find_if_not,
439 first,
440 format,
441 fourth,
442 fround,
443 ftruncate,
444 get_decoded_time,
445 sys_get_setf_method,
446 sys_get_setf_method_multiple_value,
447 get_universal_time,
448 getf,
449 ignore,
450 incf,
451 inspect,
452 intersection,
453 isqrt,
454 ldb,
455 ldb_test,
456 lisp_implementation_type,
457 logandc1,
458 logandc2,
459 lognand,
460 lognor,
461 lognot,
462 logorc1,
463 logorc2,
464 logtest,
465 long_site_name,
466 loop,
467 machine_instance,
468 machine_type,
469 machine_version,
470 make_array,
471 make_sequence,
472 map,
473 mask_field,
474 merge,
475 mismatch,
476 (mod),
477 multiple_value_setq,
478 nintersection,
479 ninth,
480 notany,
481 notevery,
482 nset_difference,
483 nset_exclusive_or,
484 nsubstitute,
485 nsubstitute_if,
486 nsubstitute_if_not,
487 nunion,
488 phase,
489 pop,
490 position,
491 position_if,
492 position_if_not,
493 prin1_to_string,
494 princ_to_string,
495 prog_xx,
496 provide,
497 psetf,
498 push,
499 pushnew,
500 rational,
501 rationalize,
502 read_from_string,
503 reduce,
504 (rem),
505 remf,
506 remove,
507 remove_duplicates,
508 remove_if,
509 remove_if_not,
510 replace,
511 require,
512 rotatef,
513 room,
514 sbit,
515 search,
516 second,
517 set_difference,
518 set_exclusive_or,
519 setf,
520 seventh,
521 shiftf,
522 short_site_name,
523 signum,
524 sinh,
525 sixth,
526 software_type,
527 software_version,
528 some,
529 sort,
530 stable_sort,
531 step,
532 structure,
533 subsetp,
534 substitute,
535 substitute_if,
536 substitute_if_not,
537 subtypep,
538 tanh,
539 tenth,
540 third,
541 time,
542 trace,
543 type,
544 typecase,
545 typep,
546 union,
547 untrace,
548 variable,
549 vector,
550 vector_pop,
551 vector_push,
552 vector_push_extend,
553 warn,
554 with_input_from_string,
555 with_open_file,
556 with_open_stream,
557 with_output_to_string,
558 write_to_string,
559 y_or_n_p,
560 yes_or_no_p,
561 proclaim,
562 sys_proclamation,
563 special,
564 type,
565 ftype,
566 function,
567 inline,
568 notinline,
569 ignore,
570 optimize,
571 speed,
572 space,
573 safety,
574 compilation_speed,
575 declaration,
576 xx_eval_when_compile_xx,
577 clines,
578 defcfun,
579 defentry,
580 defla,
581 defcbody,
582 definline,
583 defunc,
584 void,
585 object,
586 char_xx,
587 char,
588 int,
589 float,
590 double
591 ],
592 [],
593 _Ignored).
594/*
595 Beppe
596*/
597/*
598 Beppe
599*/
600/*
601 Beppe
602*/
603/*
604 Beppe
605*/
606/*
607;; ----------------------------------------------------------------------
608*/
609/*
610;;
611*/
612/*
613(defun eval-feature (x)
614 (cond ((symbolp x)
615 (member x *features*
616 :test #'(lambda (a b)
617 (or (eql a b)
618 (and (symbolp a) (symbolp b)
619 (string-equal (symbol-name a)
620 (symbol-name b)))))))
621 ((atom x) (error ""(defun eval-feature (x)\n (cond ((symbolp x)\n (member x *features*\n :test #'(lambda (a b)\n (or (eql a b)\n\t\t\t (and (symbolp a) (symbolp b)\n\t\t\t\t (string-equal (symbol-name a)\n\t\t\t\t\t\t (symbol-name b)))))))\n\t((atom x) (error \"~ is not allowed as a feature\" x))\n ((eq (car x) 'AND)\n (dolist (x (cdr x) t) (unless (eval-feature x) (return nil))))\n ((eq (car x) 'OR)\n (dolist (x (cdr x) nil) (when (eval-feature x) (return t))))\n ((eq (car x) 'NOT)\n\t (not (eval-feature (second x))))\n\t(t (error \"~S is not a feature expression.\" x))))\n\n;;; Revised by G. Attardi\n".
622*/
623
624/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:4025 **********************/
625:-lisp_compile_to_prolog(pkg_cl,[defun,'eval-feature',[x],[cond,[[symbolp,x],[member,x,'*features*',':test',function([lambda,[a,b],[or,[eql,a,b],[and,[symbolp,a],[symbolp,b],['string-equal',['symbol-name',a],['symbol-name',b]]]]])]],[[atom,x],[error,'$STRING'("~ is not allowed as a feature"),x]],[[eq,[car,x],[quote,'AND']],[dolist,[x,[cdr,x],t],[unless,['eval-feature',x],[return,[]]]]],[[eq,[car,x],[quote,'OR']],[dolist,[x,[cdr,x],[]],[when,['eval-feature',x],[return,t]]]],[[eq,[car,x],[quote,'NOT']],[not,['eval-feature',[second,x]]]],[t,[error,'$STRING'("~S is not a feature expression."),x]]]])
626/*
627:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
628 eval_feature,
629 kw_function,
630 f_eval_feature)).
631*/
632wl:lambda_def(defun, eval_feature, f_eval_feature, [x], [[cond, [[symbolp, x], [member, x, xx_features_xx, kw_test, function([lambda, [a, b], [or, [eql, a, b], [and, [symbolp, a], [symbolp, b], [string_equal, [symbol_name, a], [symbol_name, b]]]]])]], [[atom, x], [error, '$ARRAY'([*], claz_base_character, "~ is not allowed as a feature"), x]], [[eq, [car, x], [quote, and]], [dolist, [x, [cdr, x], t], [unless, [eval_feature, x], [return, []]]]], [[eq, [car, x], [quote, or]], [dolist, [x, [cdr, x], []], [when, [eval_feature, x], [return, t]]]], [[eq, [car, x], [quote, not]], [not, [eval_feature, [second, x]]]], [t, [error, '$ARRAY'([*], claz_base_character, "~S is not a feature expression."), x]]]]).
633wl:arglist_info(eval_feature, f_eval_feature, [x], arginfo{all:[x], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[x], opt:0, req:[x], rest:0, sublists:0, whole:0}).
634wl: init_args(x, f_eval_feature).
635
640f_eval_feature(X_In, FnResult) :-
641 GEnv=[bv(x, X_In)],
642 catch(( ( get_var(GEnv, x, X_Get),
643 ( is_symbolp(X_Get)
644 -> get_var(GEnv, x, X_Get9),
645 get_var(GEnv, xx_features_xx, Xx_features_xx_Get),
646 f_member(X_Get9,
647 Xx_features_xx_Get,
648
649 [ kw_test,
650 closure(kw_function,
651 [ClosureEnvironment|GEnv],
652 Whole,
653 LResult,
654 [a, b],
655 (get_var(ClosureEnvironment, a, A_Get), get_var(ClosureEnvironment, b, B_Get), f_eql(A_Get, B_Get, FORM1_Res), FORM1_Res\==[], LResult=FORM1_Res->true;get_var(ClosureEnvironment, a, A_Get14), (is_symbolp(A_Get14)->get_var(ClosureEnvironment, b, B_Get18), (is_symbolp(B_Get18)->get_var(ClosureEnvironment, a, A_Get21), f_symbol_name(A_Get21, String_equal_Param), get_var(ClosureEnvironment, b, B_Get22), f_symbol_name(B_Get22, Symbol_name_Ret), f_string_equal(String_equal_Param, Symbol_name_Ret, [], TrueResult), TrueResult24=TrueResult;TrueResult24=[]), _5986=TrueResult24;_5986=[]), LResult=_5986),
656
657 [ lambda,
658 [a, b],
659
660 [ or,
661 [eql, a, b],
662
663 [ and,
664 [symbolp, a],
665 [symbolp, b],
666
667 [ string_equal,
668 [symbol_name, a],
669 [symbol_name, b]
670 ]
671 ]
672 ]
673 ])
674 ],
675 TrueResult85),
676 _5806=TrueResult85
677 ; get_var(GEnv, x, X_Get31),
678 ( X_Get31\=[CAR|CDR]
679 -> get_var(GEnv, x, X_Get34),
680 f_error(
681 [ '$ARRAY'([*],
682 claz_base_character,
683 "~ is not allowed as a feature"),
684 X_Get34
685 ],
686 TrueResult83),
687 ElseResult86=TrueResult83
688 ; get_var(GEnv, x, X_Get36),
689 f_car(X_Get36, PredArg1Result),
690 ( is_eq(PredArg1Result, and)
691 -> LEnv=GEnv,
692 save_special(sv(t, [], symbol_value, Symbol_value)),
693 get_var(LEnv, x, X_Get42),
694 f_cdr(X_Get42, List),
695 BV=bv(x, Ele),
696 BlockExitEnv=[BV|LEnv],
697 forall(member(Ele, List),
698 ( nb_setarg(2, BV, Ele),
699 get_var(BlockExitEnv, x, X_Get45),
700 f_eval_feature(X_Get45, IFTEST43),
701 ( IFTEST43\==[]
702 -> _6838=[]
703 ; throw(block_exit([], [])),
704 _6838=ThrowResult
705 )
706 )),
707 restore_special(sv(t,
708 [],
709 symbol_value,
710 Symbol_value)),
711 ElseResult84=t
712 ; get_var(GEnv, x, X_Get55),
713 f_car(X_Get55, PredArg1Result57),
714 ( is_eq(PredArg1Result57, or)
715 -> LEnv60=[bv([], [])|GEnv],
716 get_var(LEnv60, x, X_Get61),
717 f_cdr(X_Get61, List72),
718 BV69=bv(x, Ele71),
719 BlockExitEnv67=[BV69|LEnv60],
720 forall(member(Ele71, List72),
721 ( nb_setarg(2, BV69, Ele71),
722 get_var(BlockExitEnv67, x, X_Get64),
723 f_eval_feature(X_Get64, IFTEST62),
724 ( IFTEST62\==[]
725 -> throw(block_exit([], t)),
726 _7260=ThrowResult66
727 ; _7260=[]
728 )
729 )),
730 ElseResult82=[]
731 ; get_var(GEnv, x, X_Get74),
732 f_car(X_Get74, PredArg1Result76),
733 ( is_eq(PredArg1Result76, not)
734 -> get_var(GEnv, x, X_Get77),
735 f_second(X_Get77, Eval_feature_Param),
736 f_eval_feature(Eval_feature_Param,
737 Not_Param),
738 f_not(Not_Param, TrueResult79),
739 ElseResult81=TrueResult79
740 ; get_var(GEnv, x, X_Get78),
741 f_error(
742 [ '$ARRAY'([*],
743 claz_base_character,
744 "~S is not a feature expression."),
745 X_Get78
746 ],
747 ElseResult80),
748 ElseResult81=ElseResult80
749 ),
750 ElseResult82=ElseResult81
751 ),
752 ElseResult84=ElseResult82
753 ),
754 ElseResult86=ElseResult84
755 ),
756 _5806=ElseResult86
757 )
758 ),
759 _5806=FnResult
760 ),
761 block_exit(eval_feature, FnResult),
762 true).
763:- set_opv(eval_feature, symbol_function, f_eval_feature),
764 DefunResult=eval_feature. 765/*
766:- side_effect(assert_lsp(eval_feature,
767 lambda_def(defun,
768 eval_feature,
769 f_eval_feature,
770 [x],
771
772 [
773 [ cond,
774
775 [ [symbolp, x],
776
777 [ member,
778 x,
779 xx_features_xx,
780 kw_test,
781 function(
782 [ lambda,
783 [a, b],
784
785 [ or,
786 [eql, a, b],
787
788 [ and,
789 [symbolp, a],
790 [symbolp, b],
791
792 [ string_equal,
793 [symbol_name, a],
794 [symbol_name, b]
795 ]
796 ]
797 ]
798 ])
799 ]
800 ],
801
802 [ [atom, x],
803
804 [ error,
805 '$ARRAY'([*],
806 claz_base_character,
807 "~ is not allowed as a feature"),
808 x
809 ]
810 ],
811
812 [ [eq, [car, x], [quote, and]],
813
814 [ dolist,
815 [x, [cdr, x], t],
816
817 [ unless,
818 [eval_feature, x],
819 [return, []]
820 ]
821 ]
822 ],
823
824 [ [eq, [car, x], [quote, or]],
825
826 [ dolist,
827 [x, [cdr, x], []],
828
829 [ when,
830 [eval_feature, x],
831 [return, t]
832 ]
833 ]
834 ],
835
836 [ [eq, [car, x], [quote, not]],
837 [not, [eval_feature, [second, x]]]
838 ],
839
840 [ t,
841
842 [ error,
843 '$ARRAY'([*],
844 claz_base_character,
845 "~S is not a feature expression."),
846 x
847 ]
848 ]
849 ]
850 ]))).
851*/
852/*
853:- side_effect(assert_lsp(eval_feature,
854 arglist_info(eval_feature,
855 f_eval_feature,
856 [x],
857 arginfo{ all:[x],
858 allow_other_keys:0,
859 aux:0,
860 body:0,
861 complex:0,
862 env:0,
863 key:0,
864 names:[x],
865 opt:0,
866 req:[x],
867 rest:0,
868 sublists:0,
869 whole:0
870 }))).
871*/
872/*
873:- side_effect(assert_lsp(eval_feature, init_args(x, f_eval_feature))).
874*/
875/*
876;; Revised by G. Attardi
877*/
878/*
879(defun check-no-infix (stream subchar arg)
880 (when arg
881 (error "Reading from "(defun check-no-infix (stream subchar arg)\n (when arg\n (error \"Reading from ~S: no number should appear between # and ~A\"\n\t stream subchar)))\n\n".
882*/
883
884/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:4676 **********************/
885:-lisp_compile_to_prolog(pkg_cl,[defun,'check-no-infix',[stream,subchar,arg],[when,arg,[error,'$STRING'("Reading from ~S: no number should appear between # and ~A"),stream,subchar]]])
886/*
887:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
888 check_no_infix,
889 kw_function,
890 f_check_no_infix)).
891*/
892wl:lambda_def(defun, check_no_infix, f_check_no_infix, [stream, subchar, arg], [[when, arg, [error, '$ARRAY'([*], claz_base_character, "Reading from ~S: no number should appear between # and ~A"), stream, subchar]]]).
893wl:arglist_info(check_no_infix, f_check_no_infix, [stream, subchar, arg], arginfo{all:[stream, subchar, arg], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[stream, subchar, arg], opt:0, req:[stream, subchar, arg], rest:0, sublists:0, whole:0}).
894wl: init_args(x, f_check_no_infix).
895
900f_check_no_infix(Stream_In, Subchar_In, Arg_In, FnResult) :-
901 GEnv=[bv(stream, Stream_In), bv(subchar, Subchar_In), bv(arg, Arg_In)],
902 catch(( ( get_var(GEnv, arg, IFTEST),
903 ( IFTEST\==[]
904 -> get_var(GEnv, stream, Stream_Get),
905 get_var(GEnv, subchar, Subchar_Get),
906 f_error(
907 [ '$ARRAY'([*],
908 claz_base_character,
909 "Reading from ~S: no number should appear between # and ~A"),
910 Stream_Get,
911 Subchar_Get
912 ],
913 TrueResult),
914 _8838=TrueResult
915 ; _8838=[]
916 )
917 ),
918 _8838=FnResult
919 ),
920 block_exit(check_no_infix, FnResult),
921 true).
922:- set_opv(check_no_infix, symbol_function, f_check_no_infix),
923 DefunResult=check_no_infix. 924/*
925:- side_effect(assert_lsp(check_no_infix,
926 lambda_def(defun,
927 check_no_infix,
928 f_check_no_infix,
929 [stream, subchar, arg],
930
931 [
932 [ when,
933 arg,
934
935 [ error,
936 '$ARRAY'([*],
937 claz_base_character,
938 "Reading from ~S: no number should appear between # and ~A"),
939 stream,
940 subchar
941 ]
942 ]
943 ]))).
944*/
945/*
946:- side_effect(assert_lsp(check_no_infix,
947 arglist_info(check_no_infix,
948 f_check_no_infix,
949 [stream, subchar, arg],
950 arginfo{ all:[stream, subchar, arg],
951 allow_other_keys:0,
952 aux:0,
953 body:0,
954 complex:0,
955 env:0,
956 key:0,
957 names:[stream, subchar, arg],
958 opt:0,
959 req:[stream, subchar, arg],
960 rest:0,
961 sublists:0,
962 whole:0
963 }))).
964*/
965/*
966:- side_effect(assert_lsp(check_no_infix, init_args(x, f_check_no_infix))).
967*/
968/*
969(defun sharp-+-reader (stream subchar arg)
970 (check-no-infix stream subchar arg)
971 (let ((feature (read stream t nil t)))
972 (if (and (not *read-suppress*) (eval-feature feature))
973 (read stream t nil t)
974 (let ((*read-suppress* t)) (read stream t nil t) (values)))))
975
976*/
977
978/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:4825 **********************/
979:-lisp_compile_to_prolog(pkg_cl,[defun,'sharp-+-reader',[stream,subchar,arg],['check-no-infix',stream,subchar,arg],[let,[[feature,[read,stream,t,[],t]]],[if,[and,[not,'*read-suppress*'],['eval-feature',feature]],[read,stream,t,[],t],[let,[['*read-suppress*',t]],[read,stream,t,[],t],[values]]]]])
980/*
981:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
982 sharp_c43_reader,
983 kw_function,
984 f_sharp_c43_reader)).
985*/
986wl:lambda_def(defun, sharp_c43_reader, f_sharp_c43_reader, [stream, subchar, arg], [[check_no_infix, stream, subchar, arg], [let, [[feature, [read, stream, t, [], t]]], [if, [and, [not, xx_read_suppress_xx], [eval_feature, feature]], [read, stream, t, [], t], [let, [[xx_read_suppress_xx, t]], [read, stream, t, [], t], [values]]]]]).
987wl:arglist_info(sharp_c43_reader, f_sharp_c43_reader, [stream, subchar, arg], arginfo{all:[stream, subchar, arg], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[stream, subchar, arg], opt:0, req:[stream, subchar, arg], rest:0, sublists:0, whole:0}).
988wl: init_args(x, f_sharp_c43_reader).
989
994f_sharp_c43_reader(Stream_In, Subchar_In, Arg_In, FnResult) :-
995 GEnv=[bv(stream, Stream_In), bv(subchar, Subchar_In), bv(arg, Arg_In)],
996 catch(( ( ( get_var(GEnv, arg, Arg_Get),
997 get_var(GEnv, stream, Stream_Get)
998 ),
999 get_var(GEnv, subchar, Subchar_Get),
1000 f_check_no_infix(Stream_Get,
1001 Subchar_Get,
1002 Arg_Get,
1003 No_infix_Ret),
1004 get_var(GEnv, stream, Stream_Get13),
1005 f_read(Stream_Get13, t, [], t, Feature_Init),
1006 LEnv=[bv(feature, Feature_Init)|GEnv],
1007 get_var(LEnv, xx_read_suppress_xx, Xx_read_suppress_xx_Get),
1008 ( Xx_read_suppress_xx_Get==[]
1009 -> get_var(LEnv, feature, Feature_Get),
1010 f_eval_feature(Feature_Get, TrueResult),
1011 IFTEST=TrueResult
1012 ; IFTEST=[]
1013 ),
1014 ( IFTEST\==[]
1015 -> get_var(LEnv, stream, Stream_Get23),
1016 f_read(Stream_Get23, t, [], t, TrueResult25),
1017 LetResult=TrueResult25
1018 ; locally_set(xx_read_suppress_xx,
1019 t,
1020 (get_var(LEnv, stream, Stream_Get24), f_read(Stream_Get24, t, [], t, T), nb_setval('$mv_return', []))),
1021 LetResult=[]
1022 )
1023 ),
1024 LetResult=FnResult
1025 ),
1026 block_exit(sharp_c43_reader, FnResult),
1027 true).
1028:- set_opv(sharp_c43_reader, symbol_function, f_sharp_c43_reader),
1029 DefunResult=sharp_c43_reader. 1030/*
1031:- side_effect(assert_lsp(sharp_c43_reader,
1032 lambda_def(defun,
1033 sharp_c43_reader,
1034 f_sharp_c43_reader,
1035 [stream, subchar, arg],
1036
1037 [ [check_no_infix, stream, subchar, arg],
1038
1039 [ let,
1040 [[feature, [read, stream, t, [], t]]],
1041
1042 [ if,
1043
1044 [ and,
1045 [not, xx_read_suppress_xx],
1046 [eval_feature, feature]
1047 ],
1048 [read, stream, t, [], t],
1049
1050 [ let,
1051 [[xx_read_suppress_xx, t]],
1052 [read, stream, t, [], t],
1053 [values]
1054 ]
1055 ]
1056 ]
1057 ]))).
1058*/
1059/*
1060:- side_effect(assert_lsp(sharp_c43_reader,
1061 arglist_info(sharp_c43_reader,
1062 f_sharp_c43_reader,
1063 [stream, subchar, arg],
1064 arginfo{ all:[stream, subchar, arg],
1065 allow_other_keys:0,
1066 aux:0,
1067 body:0,
1068 complex:0,
1069 env:0,
1070 key:0,
1071 names:[stream, subchar, arg],
1072 opt:0,
1073 req:[stream, subchar, arg],
1074 rest:0,
1075 sublists:0,
1076 whole:0
1077 }))).
1078*/
1079/*
1080:- side_effect(assert_lsp(sharp_c43_reader, init_args(x, f_sharp_c43_reader))).
1081*/
1082/*
1083(set-dispatch-macro-character #\# #\+ 'sharp-+-reader)
1084*/
1085
1086/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5093 **********************/
1087:-lisp_compile_to_prolog(pkg_cl,['set-dispatch-macro-character',#\(#),#\(+),[quote,'sharp-+-reader']])
1088:- f_set_dispatch_macro_character(#\(#), #\(+), sharp_c43_reader, [], _Ignored).
1089/*
1090(set-dispatch-macro-character #\# #\+ 'sharp-+-reader
1091 (sys::standard-readtable))
1092
1093*/
1094
1095/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5148 **********************/
1096:-lisp_compile_to_prolog(pkg_cl,['set-dispatch-macro-character',#\(#),#\(+),[quote,'sharp-+-reader'],['sys::standard-readtable']])
1097/*
1098:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1099 sys_standard_readtable,
1100 kw_function,
1101 f_sys_standard_readtable)).
1102*/
1103:- f_sys_standard_readtable(Standard_readtable_Ret),
1104 f_set_dispatch_macro_character(#\(#),
1105 #\(+),
1106 sharp_c43_reader,
1107 [Standard_readtable_Ret],
1108 _Ignored).
1109/*
1110(defun sharp---reader (stream subchar arg)
1111 (check-no-infix stream subchar arg)
1112 (let ((feature (read stream t nil t)))
1113 (if (or *read-suppress* (eval-feature feature))
1114 (let ((*read-suppress* t)) (read stream t nil t) (values))
1115 (read stream t nil t))))
1116
1117*/
1118
1119/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5260 **********************/
1120:-lisp_compile_to_prolog(pkg_cl,[defun,'sharp---reader',[stream,subchar,arg],['check-no-infix',stream,subchar,arg],[let,[[feature,[read,stream,t,[],t]]],[if,[or,'*read-suppress*',['eval-feature',feature]],[let,[['*read-suppress*',t]],[read,stream,t,[],t],[values]],[read,stream,t,[],t]]]])
1121/*
1122:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1123 sharp_reader,
1124 kw_function,
1125 f_sharp_reader)).
1126*/
1127wl:lambda_def(defun, sharp_reader, f_sharp_reader, [stream, subchar, arg], [[check_no_infix, stream, subchar, arg], [let, [[feature, [read, stream, t, [], t]]], [if, [or, xx_read_suppress_xx, [eval_feature, feature]], [let, [[xx_read_suppress_xx, t]], [read, stream, t, [], t], [values]], [read, stream, t, [], t]]]]).
1128wl:arglist_info(sharp_reader, f_sharp_reader, [stream, subchar, arg], arginfo{all:[stream, subchar, arg], allow_other_keys:0, aux:0, body:0, complex:0, env:0, key:0, names:[stream, subchar, arg], opt:0, req:[stream, subchar, arg], rest:0, sublists:0, whole:0}).
1129wl: init_args(x, f_sharp_reader).
1130
1135f_sharp_reader(Stream_In, Subchar_In, Arg_In, FnResult) :-
1136 GEnv=[bv(stream, Stream_In), bv(subchar, Subchar_In), bv(arg, Arg_In)],
1137 catch(( ( ( get_var(GEnv, arg, Arg_Get),
1138 get_var(GEnv, stream, Stream_Get)
1139 ),
1140 get_var(GEnv, subchar, Subchar_Get),
1141 f_check_no_infix(Stream_Get,
1142 Subchar_Get,
1143 Arg_Get,
1144 No_infix_Ret),
1145 get_var(GEnv, stream, Stream_Get13),
1146 f_read(Stream_Get13, t, [], t, Feature_Init),
1147 LEnv=[bv(feature, Feature_Init)|GEnv],
1148 ( get_var(LEnv,
1149 xx_read_suppress_xx,
1150 Xx_read_suppress_xx_Get),
1151 Xx_read_suppress_xx_Get\==[],
1152 IFTEST=Xx_read_suppress_xx_Get
1153 -> true
1154 ; get_var(LEnv, feature, Feature_Get),
1155 f_eval_feature(Feature_Get, Eval_feature_Ret),
1156 IFTEST=Eval_feature_Ret
1157 ),
1158 ( IFTEST\==[]
1159 -> locally_set(xx_read_suppress_xx,
1160 t,
1161 (get_var(LEnv, stream, Stream_Get20), f_read(Stream_Get20, t, [], t, T), nb_setval('$mv_return', []))),
1162 LetResult=[]
1163 ; get_var(LEnv, stream, Stream_Get21),
1164 f_read(Stream_Get21, t, [], t, ElseResult),
1165 LetResult=ElseResult
1166 )
1167 ),
1168 LetResult=FnResult
1169 ),
1170 block_exit(sharp_reader, FnResult),
1171 true).
1172:- set_opv(sharp_reader, symbol_function, f_sharp_reader),
1173 DefunResult=sharp_reader. 1174/*
1175:- side_effect(assert_lsp(sharp_reader,
1176 lambda_def(defun,
1177 sharp_reader,
1178 f_sharp_reader,
1179 [stream, subchar, arg],
1180
1181 [ [check_no_infix, stream, subchar, arg],
1182
1183 [ let,
1184 [[feature, [read, stream, t, [], t]]],
1185
1186 [ if,
1187
1188 [ or,
1189 xx_read_suppress_xx,
1190 [eval_feature, feature]
1191 ],
1192
1193 [ let,
1194 [[xx_read_suppress_xx, t]],
1195 [read, stream, t, [], t],
1196 [values]
1197 ],
1198 [read, stream, t, [], t]
1199 ]
1200 ]
1201 ]))).
1202*/
1203/*
1204:- side_effect(assert_lsp(sharp_reader,
1205 arglist_info(sharp_reader,
1206 f_sharp_reader,
1207 [stream, subchar, arg],
1208 arginfo{ all:[stream, subchar, arg],
1209 allow_other_keys:0,
1210 aux:0,
1211 body:0,
1212 complex:0,
1213 env:0,
1214 key:0,
1215 names:[stream, subchar, arg],
1216 opt:0,
1217 req:[stream, subchar, arg],
1218 rest:0,
1219 sublists:0,
1220 whole:0
1221 }))).
1222*/
1223/*
1224:- side_effect(assert_lsp(sharp_reader, init_args(x, f_sharp_reader))).
1225*/
1226/*
1227(set-dispatch-macro-character #\# #\- 'sharp---reader)
1228*/
1229
1230/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5521 **********************/
1231:-lisp_compile_to_prolog(pkg_cl,['set-dispatch-macro-character',#\(#),#\(-),[quote,'sharp---reader']])
1232:- f_set_dispatch_macro_character(#\(#), #\(-), sharp_reader, [], _Ignored).
1233/*
1234(set-dispatch-macro-character #\# #\- 'sharp---reader
1235 (sys::standard-readtable))
1236
1237;;; ----------------------------------------------------------------------
1238
1239*/
1240
1241/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5576 **********************/
1242:-lisp_compile_to_prolog(pkg_cl,['set-dispatch-macro-character',#\(#),#\(-),[quote,'sharp---reader'],['sys::standard-readtable']])
1243/*
1244:- side_effect(generate_function_or_macro_name([name='GLOBAL', environ=env_1],
1245 sys_standard_readtable,
1246 kw_function,
1247 f_sys_standard_readtable)).
1248*/
1249:- f_sys_standard_readtable(Standard_readtable_Ret),
1250 f_set_dispatch_macro_character(#\(#),
1251 #\(-),
1252 sharp_reader,
1253 [Standard_readtable_Ret],
1254 _Ignored).
1255/*
1256;; ----------------------------------------------------------------------
1257*/
1258/*
1259#+CLOS
1260(export '(
1261 add-method
1262 call-next-method
1263 change-class
1264 class-changed
1265 class-name
1266 class-of
1267 defclass
1268 defgeneric
1269 define-method-combination
1270 defmethod
1271 ensure-generic-function
1272 find-class
1273 generic-flet
1274 generic-function
1275 generic-labels
1276 get-method
1277 initialize-instance
1278 invalid-method-error
1279 make-instance
1280 make-instance-obsolete
1281 make-method-call
1282 method
1283 method-combination-error
1284 method-qualifiers
1285 next-method-p
1286 no-applicable-method
1287 print-object
1288 remove-method
1289 slot-boundp
1290 slot-exists-p
1291 slot-makunbound
1292 slot-missing
1293 slot-unbound
1294 slot-value
1295 symbol-macrolet
1296 update-instance-structure
1297 with-accessors
1298 with-added-methods
1299 with-slots
1300
1301 class
1302 built-in
1303 standard-class
1304 standard-generic-function
1305 standard-method
1306 standard-object
1307 structure-class
1308 structure-object
1309 ))
1310
1311*/
1312
1313/*********** /home/dmiles/logicmoo_workspace/packs_usr/wam_common_lisp/prolog/wam_cl/lib/lsp/export.lsp:5764 **********************/
1314:-lisp_compile_to_prolog(pkg_cl,'$COMMENT'([flag_removed,[+,':CLOS'],[export,[quote,['add-method','call-next-method','change-class','class-changed','class-name','class-of',defclass,defgeneric,'define-method-combination',defmethod,'ensure-generic-function','find-class','generic-flet','generic-function','generic-labels','get-method','initialize-instance','invalid-method-error','make-instance','make-instance-obsolete','make-method-call',method,'method-combination-error','method-qualifiers','next-method-p','no-applicable-method','print-object','remove-method','slot-boundp','slot-exists-p','slot-makunbound','slot-missing','slot-unbound','slot-value','symbol-macrolet','update-instance-structure','with-accessors','with-added-methods','with-slots',class,'built-in','standard-class','standard-generic-function','standard-method','standard-object','structure-class','structure-object']]]]))
1315
1316%; Total compilation time: 3.658 seconds
1317