API tools faq
paste
logicmoo

CommonLisp written in SubLisp

logicmoo
Feb 14th, 2015
449
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Lisp 78.70 KB | None | 0 0
raw download clone embed print report
  1. #|
  2.  
  3. SubL is a programming language intended to be very similar to a simplified version of Common Lisp where those features that are either
  4. complex, rarely-used, or difficult to implement in a prodecural language have been removed. Lets put some back.
  5.  
  6. Sometimes it is hard to port your Common Lisp applications to SubL.
  7. Until you do, you will not be able to translate-block-it with Cyc's internal translate-blockr.
  8.  
  9. During the interim, here are some usefull functions and macros.
  10. <b>Please help out by [http:://www.cycfoundation.org/foundation/index.php?title=Common_Lisp_Compatibility&action=edit editing] this page.</b>
  11.  
  12. The goal will be here to implement as much of the Common Lisp language as possible based on the
  13. [http:://www.lisp.org/HyperSpec/FrontMatter/Chapter-Index.html HyperSpec]
  14.  
  15.  
  16. *[[Programming]] is based largly on [http:://www.cyc.com/cycdoc/ref/subl-reference.html SubL Reference]
  17.  
  18. |#
  19. ;;<pre><nowiki>
  20.  
  21. ;;; -*- Mode: LISP; Package: CYC; Syntax: ANSI-Common-Lisp -*-
  22. ;;
  23. ;; Douglas R. Miles
  24. ;;
  25. ;; Saved into a file called common.lisp
  26. ;; 05/08/2006  (load "cynd/common.lisp")
  27.  
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;; Intitally setup packages
  30. ;;
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;;(in-package "CYC")
  33.  
  34.  
  35.  
  36.  
  37. #|
  38. ;;Initialize the task processor pool for requests.
  39. (INITIALIZE-API-TASK-PROCESSORS)
  40. ;;Initialize the task processor pool for requests.
  41. (INITIALIZE-BG-TASK-PROCESSORS )
  42. ;;Initialize the task processor pool for requests.
  43. (INITIALIZE-CONSOLE-TASK-PROCESSORS )
  44.  (SHOW-API-TASK-PROCESSORS )
  45. ;;Provides a convenient alias for DISPLAY-API-TASK-PROCESSORS.
  46. (SHOW-API-TP-MSGS  )
  47. ;;Show and reset the task processor background messages for thetask-process-pool.
  48. (SHOW-BG-TP-MSGS )
  49. ;;Show and reset the task processor background messages for thetask-process-pool.
  50. (SHOW-CONSOLE-TP-MSGS  )
  51. ;;(TRANSLATOR-RET-OPTIMIZE-BODY )
  52. |#
  53. ;;(define dispatch-macro-in-package (s c n))
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. ;; The package CL uses SYSTEM as it's shadow
  56. ;;
  57. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  58. (defvar *SYSTEM-PACKAGE* (sl::make-package "SYSTEM" '() '("SYS")))
  59. (defvar *COMMON-LISP-PACKAGE* (sl::make-package "COMMON-LISP" '("SYS") '("CL" "LISP")))
  60. (defvar *default-package-use* (list *COMMON-LISP-PACKAGE* *SYSTEM-PACKAGE* *CYC-PACKAGE* *SUBLISP-PACKAGE*))
  61. ;;(defvar *COMMON-LISP-USER-PACKAGE* (sl::make-package "COMMON-LISP-USER" '("CL" "CYC") '("USER")))
  62.  
  63. (import () :CL)
  64. (import () :SYS)
  65.  
  66. (DEFVAR *SUBLISP-DEFMACRO* (find-symbol "DEFMACRO" :SUBLISP))
  67. (DEFVAR *SUBLISP-DEFINE* (find-symbol "DEFINE" :SUBLISP))
  68. (DEFVAR *SUBLISP-LAMBDA* (find-symbol "LAMBDA" :SUBLISP))
  69. (DEFVAR *SUBLISP-FUNCTION* (find-symbol "FUNCTION" :SUBLISP))
  70.  
  71. (defvar *T-PACKAGE* *package*)
  72. (defvar *T-READTABLE* (COPY-READTABLE *READTABLE*))
  73.  
  74. ;;(defmacro cl-lambda (args &rest stuff) (ret `#'(lambda ,args (ret (progn ,@stuff)))))
  75. (define define-anonymous-function (arguments body)
  76.    (clet ((name (gensym "LAMBDA-"))) (eval `(define ,name ,arguments (ret (progn ,@body)))) (ret (symbol-function name))))
  77.  
  78. (defmacro cl-lambda (arguments &body body)  (ret (define-anonymous-function arguments body)))
  79.  
  80.  
  81.  
  82. (define force-format (strm &rest body)(clet ((res (apply #'format (cons strm body))))(pif (streamp strm) (output-stream-p strm) (force-output))(ret res)))
  83. (define force-princ (&rest body)(clet ((res (apply #'princ body)))(force-output)(ret res)))
  84. (define force-print (&rest body) (clet ((body (fif (equal 1 (length body)) (car body) body))(res (print body)))(force-output)(ret res)))
  85. (define lisp () (load "common.lisp")(load "common-lisp.lisp")(in-package :SYS ))
  86.  
  87. ;;EXPAND-DEFINE-LIST-ELEMENT-PREDICATOR  (FUNCTION-NAME FUNCTION-SCOPE ELEMENT-VAR TYPE BODY)
  88. ;; ARGNAMES-FROM-ARGLIST  
  89. ;;MAKE-PROCESS-WITH-ARGS  (NAME FUNCTION &OPTIONAL ARGS)
  90.  
  91. (define consify (list) (ret (fif (consp list) list (fif list (list list) ()))))
  92. (defmacro every (fn &rest seq) (ret (every-list fn seq)))
  93. (defmacro every-list (fn seq) (ret (fif (car seq) (cand (apply fn (mapcar #'car seq)) (every-list fn (mapcar #'cdr seq))) t)))
  94. (defmacro puthash (key value table) (ret (sethash key table value)))
  95. (defmacro some (fn &rest seq) (ret (some-list fn seq)))
  96. (defmacro some-list (fn seq) (ret (pwhen (car seq) (cor (apply fn (mapcar #'car seq)) (some-list fn (mapcar #'cdr seq))))))
  97. (defmacro and (&rest body) (ret (fif body (fif (cdr body) `(pwhen ,(car body) (and ,@(cdr body)))`,(car body)))))
  98. (defmacro assert (test &rest body))
  99. (defmacro defsetf (access-fn update-fn) (ret `(SL::_DEF-CSETF ,access-fn ,update-fn)))
  100. (defmacro destructuring-bind (pattern datum &rest body)(ret `(cdestructuring-bind ,pattern ,datum (trace-progn ,@body))))
  101. (defmacro do (var+list exit &rest body) (ret `(cdo (,@(mapcar #'trace-varinit var+list)) ,(trace-each exit) (trace-progn ,@body))))
  102. (defmacro dolist (var+list &rest body) (ret `(cdolist (,(car var+list) ,(second var+list)) (trace-progn  ,@body))))
  103. (defmacro dotimes (var integer &rest body) (ret `(cdotimes ,var (trace-lisp ,integer) (trace-progn  ,@body))))
  104. (defmacro handler-case (form &rest cases) (ret form))
  105. (defmacro if (cond true &optional false) (ret `(fif (trace-lisp ,cond) (trace-progn ,true) (trace-progn ,false))))
  106. (defmacro let (var+list &rest body) (ret `(clet (,@(mapcar #'trace-varinit var+list)) (trace-progn ,@body))))
  107. (defmacro let* (var+list &rest body) (ret `(clet (,@(mapcar #'trace-varinit var+list)) (trace-progn ,@body))))
  108. (defmacro memq (item list) (ret `(member ,item ,list #'eq)))
  109. (defmacro multiple-value-bind (var+list form &rest body) (ret `(cmultiple-value-bind ,var+list ,form (trace-progn ,@body))))
  110. (defmacro or (&rest body) (ret (fif body (fif (cdr body) `(pcond ((trace-lisp ,(car body))) ((or ,@(cdr body))))`(trace-lisp ,(car body))))))
  111. (defmacro pop (place) (ret `(clet ((f1rst (car ,place))) (cpop ,place) f1rst)))
  112. (defmacro prog1 (body1 &rest body) (ret `(clet ((prog1res (trace-progn ,body1))) (trace-progn  ,@body) prog1res)))
  113. (defmacro prog2 (body1 body2 &rest body) (ret `(clet ((prog1res (trace-progn ,body1))(prog2res (trace-progn ,body2))) (trace-progn  ,@body) prog2res)))
  114. (defmacro prog3 (body1 body2 body3 &rest body) (ret `(clet ((prog1res (trace-progn ,body1))(prog2res (trace-progn ,body2))(prog3res (trace-progn ,body3))) (trace-progn  ,@body) prog3res)))
  115. (defmacro pushnew (item place &key key test test-not) (ret (fif test (list 'cpushnew item place test)(list 'cpushnew item place))))
  116. (defmacro return-from (name value) (ret `(ret ,value)))
  117. ;;(defmacro setf (&rest pairs) (ret (pwhen pairs `(sl::progn (_setf ,(car pairs) (trace-progn ,(cadr pairs)))(setf ,@(cddr pairs))))))
  118. (defmacro setf (&rest pairs) (ret `(csetf ,@pairs)))
  119. ;;todo (defmacro setq (&rest pairs) (ret (pwhen pairs `(sl::progn (csetq ,(car pairs) (trace-lisp ,(cadr pairs))) (setq ,@(cddr pairs))))))
  120. (defmacro setq (&rest pairs) (ret `(csetq ,@pairs)))
  121. (defmacro unless (cond &rest body) (ret `(punless (trace-lisp ,cond) (trace-progn  ,@body))))
  122. (defmacro when (cond &rest body) (ret `(pwhen (trace-lisp ,cond) (trace-progn  ,@body))))
  123. (defmacro typep (form type) (ret (cor (eq type t)(same-classes (type-of form) type))))
  124. (defmacro cond (&rest body) (ret (cons 'pcond (mapcar #'(lambda (x) (ret `( ,@(mapcar #'(lambda (xz) (ret `(trace-lisp ,xz))) x)))) body))))
  125. (defmacro case (test &rest body) (ret `(pcase ,test ,@(mapcar #'(lambda (x) (ret `(,(car x) (trace-progn ,@(cdr x))) )) body))))
  126. (defmacro eval-when (a &rest b) (ret (cons 'trace-progn b)))
  127. (defvar internal-time-units-per-second *internal-time-units-per-second*)
  128.  
  129. (defconstant most-positive-fixnum *most-positive-fixnum* "is that fixnum closest in value to positive infinity provided by the implementation, and greater than or equal to both 2^15 - 1 and array-dimension-limit.")
  130. (defconstant most-negative-fixnum *most-negative-fixnum* "is that fixnum closest in value to negative infinity provided by the implementation, and less than or equal to -2^15")
  131.  
  132. ;; cunwind-protect hozed multiple-value-lists so thats the reason for the 'prognvals' weirdness
  133. (defmacro with-package-case (package readcase &rest body) (ret
  134.   `(clet ((*READTABLE* *T-READTABLE*)(*PACKAGE* *T-PACKAGE*)
  135.       (prognval nil)
  136.           (ocase (READTABLE-CASE *READTABLE*))(opack (string (package-name *PACKAGE*))))
  137.           (in-package (string (fif (packagep ,package)(package-name ,package) ,package)))
  138.           (CSETF (READTABLE-CASE *READTABLE*) ,readcase)
  139.       (cunwind-protect (csetf prognvals (multiple-value-list (progn ,@body)))
  140.       (CSETF (READTABLE-CASE *READTABLE*) ocase)(in-package opack)(values-list prognvals)))))
  141.  
  142.  
  143. ;;  Read up to the char specified
  144. (define READ-UNTIL (quit-chars &optional (stream *STANDARD-INPUT*)(retstr ""))
  145.      (cdo ((lastchar (read-char stream)(read-char stream)))
  146.           ((member lastchar quit-chars)(unread-char lastchar stream )(ret (values retstr lastchar)))
  147.         (csetq retstr (cconcatenate retstr (string lastchar)))))
  148.  
  149.  
  150. ;; #>CL ::DEFINE interns a non-exported non-inherited into package CL
  151. ;; #>CL ::DEFINE interns an exported non-inherited into package CL
  152. ;; maybe somehow/day use the SUBLISP::SHARPSIGN-COLON-RMF reader
  153. (define IN-PACKAGE-RMF (stream c n &optional (into-package *KEYWORD-PACKAGE*)(pop-package *PACKAGE*)(exported :INTERNAL))
  154.       (clet ( symbol found access symbolname (stream (fif (streamp stream) stream *STANDARD-INPUT*)))
  155.       ;; (force-print stream c n)
  156.        (cunwind-protect
  157.         (progn
  158.           (in-package (package-name into-package))
  159.           (csetq found (read-from-string (read-until '(#\: #\Space) stream "")))
  160.           (csetq found (eval found))
  161.           (punless (packagep found) (csetq found (find-package (string found))))          
  162.           (pwhen (packagep found) (csetq into-package found))
  163.           ;;(punless into-package (cerror "(MAKE-PACKAGE ~s)" "Unknown into-package: ~a" found found `(MAKE-PACKAGE ,found)))
  164.           (read-char stream)
  165.           (csetq symbolname (read-char stream))
  166.           (unread-char symbolname stream)
  167.           (punless (equal symbolname #\: )(csetq exported :EXTERNAL))
  168.           (IN-PACKAGE (package-name into-package))
  169.           (csetq symbolname (read stream nil t nil))
  170.           (pcond
  171.             ;; false alarm
  172.            ((numberp symbolname)(csetq symbol symbolname))
  173.            ;; oh well at least we READ from the PACKAGE requested
  174.            ((consp symbolname)(csetq symbol symbolname))
  175.            ;; one might use a STRINGP to ensure not to try to intern too early    "DEFINE"
  176.            ((cor (symbolp symbolname)(stringp symbolname))
  177.               (cmultiple-value-bind (symbol access)
  178.                  (find-symbol (string symbolname) into-package))
  179.               (csetq found (symbol-package symbol))
  180.               (pcase access
  181.                   (NIL
  182.                     (csetq symbol (make-symbol (string symbolname)))
  183.                     (csetq symbol (intern symbol into-package)))
  184.                   (otherwise
  185.                     (force-format t ";; ~s ~&" `(':symbolname ',symbolname ',exported ':TO ',into-package
  186.                     ':FOUND ',symbol ':IN ',found ':access ',access))
  187.                     (punless (eq found into-package)
  188.                         (csetq symbol (make-symbol (string symbolname)))
  189.                         (import symbol into-package)
  190.                         (import symbol into-package))))
  191.             (pwhen
  192.                (equal exported :EXTERNAL)
  193.                (export symbol into-package)
  194.                (import symbol pop-package)
  195.                (import symbol pop-package)))))
  196.           ;;unwound to
  197.           (IN-PACKAGE (package-name pop-package)))
  198.           (ret (values symbol T))))
  199.  
  200. (set-dispatch-macro-character #\# #\> #'IN-PACKAGE-RMF)
  201.  
  202. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  203. ;; ERROR HANDLING
  204. ;; Like the
  205. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  206.  
  207. (defvar *trace-notify* () "Trace these types")
  208. (define trace-format (type string &rest body)
  209.   (pwhen (equal type :funcall)
  210.     (pcond
  211.       ((null *trace-notify*) (ret nil))
  212.       ((equal T *trace-notify*)) ;; all funcalls
  213.       ((member (car (car rest)) *trace-notify*))
  214.       (t (ret nil))))
  215.   (pwhen (equal type :trace) (punless *trace-notify* (ret nil)))
  216.   (fresh-line)
  217.   (apply #'format (cons T (cons string body)))
  218.   (fresh-line)
  219.   (force-format t " ;;~S;;~%" *trace-stack*)
  220.   (force-output))
  221.  
  222.  
  223. (defvar *trace-stack* () "contains information about the last toplevel funcall")
  224. (csetq *trace-stack* ())
  225. (defmacro trace-dump (&optional (stack *trace-stack*) (depth 7) (offset 0))
  226.     (punless  (numberp depth) (csetq depth (fif depth 10000 0)))
  227.     (pwhen stack
  228.         (cdo ((depth depth (1- depth))(stack stack (cdr stack))(*funcall* (car stack) (car stack)))
  229.              ((cor (null stack)(> 0 depth))(ret stack))
  230.              (format t ";  STACK:~a  ~s~%" (make-string (* 5 (+ offset (length *trace-stack*)))) *funcall*)))
  231.     (format t ";  STACK ~a  ~s~%" (make-string (* 5 offset)) :EMPTY))
  232.  
  233. (defvar *current-code* :NONE "The current/parent code info")
  234. (defvar *current-eh* *error-handler* "The current/parent error handler")
  235. (defvar *results-list* :UNCALLED "The current/parent result info")
  236. (defvar *current-fn* (cons *results-list* NIL) "current frame")
  237.  
  238. (defvar *error-stack* () "The first error info")
  239. (csetq *error-stack* ())
  240.  
  241. (define make-tabs (n) (ret (format nil "(~a):~a" n (make-string (* 5 n)))))
  242.  
  243.  
  244.  
  245. (defmacro make-handler (code)
  246.   (ret #'(lambda (&rest whatevah) (ret (break "~&~&~&~&;; made-handler ~S durring: ~S ~S ~&" *error-message* whatevah code)))))
  247.          ;;(force-format t ";; ERROR ~a ~s ~s~%" (make-tabs (length *error-stack*)) *error-message* (car stack))
  248.          ;;(force-format t ";; SOURCE ~a ~s ~s~%" (make-tabs (length stack)) (car stack) ,code)
  249.          ;;(pwhen (> 0 (length *error-stack*)) (break ">0 - 10"))
  250.          ;;(rplacd (car stack) (*error-message*))
  251.        ;;  (csetq *error-stack* (cons (cons *error-message* code )*error-stack*)))))
  252.  
  253.             ;;(ret (values nil (break *error-message*)))))
  254.       ;;(ret (values nil t)))))
  255.  
  256. (defvar *err-handler* #'(lambda () (break "toplevel")))
  257. (csetq *err-handler* (make-handler "TOPLEVEL CODE"))
  258.  
  259. (csetq *current-fn* (make-handler "NO CODE"))
  260. (defvar *current-stack*  (list *current-fn*))
  261. #|
  262. (defmacro trace-lisp (code)
  263.  (clet
  264.  ((*current-fn* *current-fn*)
  265.  (*err-handler* (make-handler code))
  266.  (*results-list* *results-list*))
  267.  (csetq (*current-fn* #'(lambda (SL::&REQ-0 SL::&ENVIRONMENT ENV) (ret  (with-error-handler *err-handler* (multiple-value-list `,code ))))))
  268.   (ret `(clet ((*results-list* *results-list*)(csetq *results-list* (funcall *current-fn* (list *current-fn* )))
  269.                    (values-list *results-list*)))))
  270.  (macroexpand-1 '(trace-lisp 1))
  271.  (trace-lisp 1)
  272. |#
  273. (defmacro trace-lisp (code) (ret code))
  274. (defmacro trace-lisp (code) (ret (trace-eval code)))
  275. (defmacro trace-eval (code)
  276. (clet ((*current-fn* *current-fn*)
  277. (*err-handler* (make-handler code))
  278. (*results-list* *results-list*))  (ret
  279.  `(clet ((*current-stack* (cons *current-fn* *current-stack*))
  280.    (*current-fn* #'(lambda () (ret  
  281.          (with-error-handler *err-handler*
  282.          (multiple-value-list (progn (force-print (quotify ,CODE)) ,code )))))))
  283.        (values-list (apply *current-fn* (values)))))))
  284.  
  285. (defmacro trace-lisp (code) (ret code))
  286.  
  287. ;;(macroexpand-1 '(trace-lisp 1))(trace-lisp 1)
  288.  
  289. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  290. ;; Utility functions
  291. ;;
  292. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  293. (defmacro KeyLET (keys &rest body) (ret
  294.   `(clet ,(mapcar #'var-of keys)
  295.     ,@(mapcar #'(lambda (key) (ret `(init-keyval ,(var-of key) ,(init-of key)))) keys)
  296.     ,@body)))
  297.  
  298. (define var-of (larg)
  299.   (ret (pif (consp larg) (car larg) larg)))
  300.  
  301. (define init-of (larg)
  302.   (ret (pif (consp larg) (cadr larg) nil)))
  303.  
  304. (defmacro key-present-p (key &optional (keylistname 'lkeys))
  305.   (ret `(member-if #'(lambda (x) (ret (cand (symbolp x)(symbolp ,key) (equal (symbol-name x) (symbol-name ,key))))) ,keylistname)))
  306.  
  307. (defmacro init-keyval (key &optional default) (ret
  308.   `(csetq ,key (fif (key-present-p ',key) (cadr (key-present-p ',key)) ,default))))
  309.                
  310. (defmacro var-traceable (vx)
  311.   (cond
  312.    ((symbolp vx)
  313.      (ret (pif (char= #\& (char (symbol-name vx) 0)) (list 'quote vx) `(list 'quote ,vx))))
  314.    ((consp vx) (ret (var-traceable (car vx))))
  315.    (t (ret (list 'quote vx)))))
  316.  
  317.  
  318. (defmacro trace-initvar (var value) (ret `(funless ,var (csetq ,var (trace-progn ,value)))))
  319.  
  320. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  321. ;; trace-progn - Some of the features of the system must be accessable from everywhere
  322. ;; Like the
  323. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  324. (defparameter warning-errors 0)
  325. (defmacro trace-warn (&rest code)
  326.   (ret `(with-error-handler #'(lambda ()
  327.    (force-format t "~%;; ERRROR: ~a~%;; code: ~a~%" *error-message* ',code)
  328.    (pwhen (> (cinc warning-errors) 10) (break "trace-warn ~s >= ~a " warning-errors 10)))
  329.    (sl::progn ,@code))))
  330.  
  331. (defmacro trace-progn (&rest code) (ret (cons 'sl::progn (mapcar #'(lambda (xz) (ret `(trace-lisp ,xz))) code) )))
  332.  
  333. (defmacro trace-code (code)
  334.    (pcond
  335.        ((SELF-EVALUATING-FORM-P code)(ret code))
  336.        (nil (consp code)(ret
  337.          `(cons ',(car code)
  338.                (mapcar #'(lambda (ele)
  339.                     (with-error-handler #'(lambda ()) (ret (eval ele)))
  340.                     (ret (quote ele)))
  341.                     ',(cdr code)))))
  342.        ((consp code)(ret
  343.          `(cons ',(car code) (mapcar #'trace-code-fn ',(cdr code)))))
  344.        (t (ret (quotify code)))))
  345.  
  346.  
  347. (define coerce-package (name &optional default) (ret
  348.  (pcond
  349.    ((packagep name) (ret name))
  350.    ((find-package (string name)))
  351.    ((null name) default)
  352.     ((symbolp name)(ret (coerce-package (symbol-name name)(symbol-package name))))
  353.        (t (ret default)))))
  354.  
  355. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  356. ;; describe-symbol
  357. ;;
  358. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  359. (defvar *all-shadowing-symbols*)
  360.  
  361. (defvar *sticky-symbols* '((*SUBLISP-PACKAGE* . LAMBDA)(*SUBLISP-PACKAGE* . LAMBDA)(*SUBLISP-PACKAGE* . NIL)))
  362.  
  363. (define map-each (var fn list &rest body) (ret `(mapcar #'(lambda (e) (ret (apply ,fn (cons e ,body))))) list))
  364.  
  365. (define trace-varinit (var) (ret (fif (consp var) `(,(car var) ,@(trace-each (cdr var))) var)))
  366.  
  367. (define trace-each (list) (ret (mapcar #'(lambda (xz) (ret `(trace-lisp ,xz ))) list)))
  368.  
  369. ;;(cdo ((i 0 (1+ i))) ((= i 10))(format t "~a,~a~%" i (constant-name (find-constant-by-internal-id i))))
  370. ;;(cdo ((i 0 (1+ i))) ((= i (constant-count)))(format t "~a,~a~%" i (constant-name (find-constant-by-internal-id i))))
  371. (define nstring (sym)
  372.    (pcond
  373.       ((null sym) (ret "NIL"))
  374.       ((stringp sym) (ret sym))
  375.    ;;   ((consp sym) (ret (nstring (car sym))))
  376.       ((symbolp sym) (ret (symbol-name sym)))
  377.       ((packagep sym) (ret (package-name sym)))
  378.       ((packagep sym) (ret (nstring (find-symbol (package-name sym) :KEYWORD))))
  379.       (t (ret (write-to-string sym)))))
  380.  
  381.  
  382.  
  383. (define describe-symbol (sym &optional (packageIn *PACKAGE*))
  384.  ;;(ret (write-to-string sym))
  385.  (pwhen (consp sym) (ret (cons (describe-symbol (car sym) packageIn)(describe-symbol (cdr sym) packageIn))))
  386. ;; (pwhen (stringp sym) (csetq sym (car (find-all-symbols sym :use (append (list package *package* )(LIST-ALL-PACKAGES))))))
  387.  (clet ((package (coerce-package packageIn  *PACKAGE*))(packname (nstring package)))
  388.    (pcond
  389.      ((null sym) (ret "SL::NIL"))
  390.      ((cnot (symbolp sym))(ret (write-to-string sym)))
  391.      (t          
  392.        (clet ((name (string sym))(sympack (symbol-package sym)))
  393.         (pwhen (null sympack) (ret (format nil "~a!#:~a" packname name)))
  394.     ;;  (format t "looking up ~a::~a" (nstring sympack) name )
  395.         ;;(ret (format nil "~a::~a" (nstring sympack) name ))
  396.           (cmultiple-value-bind (suggest pstatus) (find-symbol name (coerce-package packname))
  397.               (pcase pstatus  
  398.                     (NIL (ret (format nil "~a~~!~a" packname (describe-symbol sym sympack))))
  399.                     (:inherited (ret (format nil  "~a~~~a" packname (describe-symbol suggest (symbol-package suggest)))))
  400.                     (:internal (csetq name (format nil  "::~a" name)))
  401.                     (:external (csetq name (format nil  ":~a"  name))))
  402.               (csetq name (fif (cnot (eq sympack packageIn))
  403.                   (format nil  "~a@~a" (nstring sympack) name)
  404.                   (format nil  "~a~a" (nstring sympack) name)))
  405.               (pwhen (fboundp sym)
  406.                    (csetq name (format nil "#'~a ~a \"~a\")" name (FUNCTION-SYMBOL-ARGLIST sym) (symbol-function sym))))
  407.               (pwhen (MACRO-OPERATOR-P sym)
  408.                     (csetq name (format nil "(macrocall ~a ~a)"  name  )))
  409.               (pwhen (FUNCTION-SYMBOL-P sym)
  410.                     (csetq name (format nil "(funcall ~a ~a)"  name  )))
  411.               (pwhen (boundp sym)
  412.                   (fif (keywordp sym)
  413.                         (csetq name (format nil "<~a>" name))
  414.                         (csetq name (format nil "[~a]" name)))))
  415.                     (ret name))))))
  416.  
  417.  (describe-symbol 'CONS)
  418.  
  419.  
  420. (define better-symbol (suggest current) (ret (> (symbol-priority suggest)(symbol-priority current))))
  421.  
  422. (define symbol-priority (sym &optional (start 1))
  423.   (pwhen (cor (null sym)(keywordp sym)) (ret 0))
  424.   (pwhen (fboundp sym) (cinc start 5))
  425.   (pwhen (boundp sym) (cinc start 3))
  426.   (pwhen (member-if #'(lambda (a) (ret (search a (symbol-name sym)))) '("&" "#" "@" "%" "*" "_"))(cinc start 1))
  427.   (ret start))
  428.  
  429. (define share-symbols (&optional (from (remove *KEYWORD-PACKAGE* (LIST-ALL-PACKAGES))) (to *PACKAGE*)(count 0))
  430.   (punless from (csetq from (remove *KEYWORD-PACKAGE* (LIST-ALL-PACKAGES))))
  431.   (punless (consp from) (csetq from (list from)))
  432.   (punless to (csetq to *PACKAGE*))
  433.   (punless (consp to) (csetq from (remove to from)) (csetq to (list to)))
  434.   (cdo-all-symbols (s)
  435.     (clet ((f (symbol-package s)))
  436.        (pwhen (member f from))
  437.          (clet ((w (symbol-priority s)))
  438.          (pwhen (> w 1)
  439.            (cdolist (p to)
  440.               (pwhen (> w (symbol-priority (find-symbol (symbol-name s) p)))
  441.                  ;;(FORCE-FORMAT t ";; importing ~a::~a <- ~a ~&"  p s f)
  442.                  (cinc count)(import s p)(import s p)))))))
  443.     (FORCE-FORMAT t ";; shared ~a symbols" count))
  444.  
  445. (define RESHARE-SYMBOLS ()
  446.  (clet ((usefull-packages (remove *KEYWORD-PACKAGE* (LIST-ALL-PACKAGES))))
  447.    (share-symbols usefull-packages (remove *COMMON-LISP-PACKAGE* usefull-packages)))
  448.  (cdo-symbols (sym *SYSTEM-PACKAGE*) (export sym *SYSTEM-PACKAGE*)))
  449.  
  450. (define best-symbol (current &optional packsearch)
  451.   (fif current
  452.       (fif (consp current)
  453.          (cons (best-symbol (car current) packsearch)(best-symbol (cdr current) packsearch))
  454.          (fif (symbolp current)
  455.             (clet ((initial current)(best current))
  456.                (cdolist (pack (consify (fif packsearch packsearch (list-all-packages))))
  457.                     (csetq best (better-symbol best (find-symbol (string (nstring current)) pack))))
  458.                (ret (values best current)))))))
  459.        
  460. ;; (use-symbol 'SYS::STREAM-OPEN-P :CYC #'better-symbol  :external)          
  461. (define use-symbol (symbols &optional (target *package*) (keep #'better-symbol) (inheriting :external))
  462.     (csetq target (coerce-package target))
  463.  
  464.     (fif (consp symbols)  (ret (sl::mapcar #'(lambda (x) (ret (use-symbol x target keep inheriting))) symbols)))
  465.  
  466.     (punless (cand symbols (symbolp symbols)) symbols)
  467.  
  468.     (clet ((from *package*)(name (symbol-name symbols))(package (symbol-package symbols)))      
  469.         (cmultiple-value-bind (suggest pstatus) (find-symbol name package)
  470.          (pwhen (cnot (eq symbols suggest)) (force-format t "; Rotten symbol ~a instead of ~a~%" (describe-symbol suggest package)
  471.                             (describe-symbol symbols package)))
  472.           (cmultiple-value-bind (visible tstatus) (find-symbol name target)
  473.               (pwhen
  474.                   ((null visible) (shadowing-import symbols target)))
  475.                  #|                      
  476.                  ((eq suggest visible) (ret (values visible tstatus))) ;;  (force-format t ";; ~a ~a~%" tstatus (describe-symbol suggest target))                    
  477.                  ((cand (functionp keep)(eq visible (funcall keep suggest visible)))
  478.                      (force-format t "; Keeping ~a instead of ~a mode = ~a~%" (describe-symbol visible target) (describe-symbol suggest target) pstatus)
  479.                      (ret (values visible tstatus)))
  480.                  ((null suggest) (ret (values NIL NIL))) ;;  (force-format t ";; ~a ~a~%" tstatus (describe-symbol suggest target))
  481.                  (t
  482.                    (force-format t "; Using ~a instead of ~a mode = ~a~%" (describe-symbol suggest target) (describe-symbol visible target) tstatus)
  483.                    (shadowing-import package visible)
  484.                    (pwhen (equal tstatus :inherited) (import visible target))
  485.                    (csetq pstatus tstatus)
  486.                    (trace-warn (unintern visible target)))))
  487.                (pcase pstatus  
  488.                     (:internal ;;(force-format t ";; Interning ~a~%" (describe-symbol suggest target))
  489.                        (sl::import suggest target)(sl::intern suggest target))
  490.                     (:external ;;(force-format t ";; Exporting ~a~%" (describe-symbol suggest target))
  491.                        (sl::import suggest target)(sl::intern suggest target)(sl::export suggest target))
  492.                     (:inherited ;;(force-format t ";; Inheriting ~a~%" (describe-symbol suggest target))
  493.                        (sl::import suggest target)(sl::export suggest target)))
  494.                        |#
  495.              (ret (values suggest pstatus))))))
  496.                  
  497.  
  498. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  499. ;; USE-PACKAGE
  500. ;;
  501. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  502. (define USE-PACKAGE (package &optional (target *package*) (keep #'better-symbol)(inheriting :external)done)
  503.     (csetq target (coerce-package target))
  504.     (cdolist (pack (consify package))
  505.         (csetq pack (coerce-package pack))
  506.         (cdo-external-symbols (sym pack)
  507.          (format t ";  POSSIBLY USING ~a ~%" sym)
  508.             (csetq done (cons (use-symbol sym target keep inheriting) done))))
  509.      (ret done))
  510.  
  511.  
  512. (define UNUSE-PACKAGE (package &optional (target *package*) (keep #'better-symbol)(inheriting :external)done)
  513.     (csetq target (coerce-package target))
  514.     (cdolist (pack (consify package))
  515.         (csetq pack (coerce-package pack))
  516.         (cdo-external-symbols (sym pack)
  517.            (clet ((status (cmultiple-value-list (find-symbol (symbol-name sym) target))))
  518.              (pwhen (eq (symbol-package (car status)) package)
  519.                   (pwhen (eq :INHERITED (second status))
  520.                    (unimport sym target)
  521.                    (unintern (make-shadow (symbol-name sym) target))))))))
  522.  
  523. (define import-in-all (symbols &optional importpacks)
  524.     (cdolist (into (consify (fif importpacks importpacks (list-all-packages))))
  525.        (import symbols into)))
  526.  
  527.  
  528. ;;; shadowing-import  --  Public
  529. ;;;
  530. ;;;    If a conflicting symbol is present, unintern it, otherwise just
  531. ;;; stick the symbol in.
  532. (define make-shadow (symbol &optional (package *package*) (internals *sticky-symbols*) imports)
  533.   (csetq package (coerce-package package *PACKAGE*))
  534.  (pcond
  535.    ((null symbol) (ret nil))
  536.    ((consp symbol)(ret (cons (make-shadow (car symbol) package internals imports)(make-shadow (cdr symbol) package internals imports))))
  537.    ((symbolp symbol)(ret (make-shadow (symbol-name symbol) package internals imports)))
  538.    ((stringp symbol)
  539.      (clet ((pstatus ())(found  (string-member symbol internals)))
  540.        ;;(pwhen found (throw (car found)))
  541.        (cmultiple-value-bind
  542.           (found pstatus) (find-symbol symbol package)
  543.            (pwhen (null pstatus)
  544. ;;              (csetq symbol (make-symbol symbol))
  545.               (csetq symbol (intern symbol package))
  546.               (export symbol package)
  547.              (ret symbol))
  548.             (clet ((fpack (symbol-package found)))
  549.               (punless (eq fpack package)
  550.                   (pcase pstatus
  551.                     (:inherited
  552.                        (csetq symbol (make-symbol (string symbol)))
  553.                        (import symbol package)
  554.                        (import symbol package)
  555.                        (export symbol package)
  556.                (ret symbol))
  557.                     (:external
  558.                        (csetq symbol (make-symbol (string symbol)))
  559.                        (unexport found package)
  560.                        (import symbol package)
  561.                        (import symbol package)
  562.                        (export symbol package)
  563.                (ret symbol))
  564.                     (:internal
  565.                        (csetq symbol (make-symbol (string symbol)))
  566.                        (import symbol package)
  567.                        (import symbol package)
  568.                (ret symbol))
  569.                ))
  570.          ;; (print `(found ,pstatus ,fpack ,found))
  571.          )
  572.  
  573.                 (ret found))))
  574.       (t (ret symbol))))
  575.  
  576. ;;ARGNAMES-FROM-ARGLIST
  577. ;;  (translate-varblock 'A '(B) '(progn B))
  578. ;; (FUNCTION-SYMBOL-ARGLIST  '
  579. (define translate-varblock (name patternIn bodyIn)
  580.  (clet ((pattern patternIn)(nargs ())(body bodyIn))
  581.      (punless (consp body)
  582.         (pwhen body (print body)
  583.           (break "translate-varblock bodyIn was not list")))
  584.       (csetq body (translate-block bodyIn 'form name))
  585.       (cdo ((op (car pattern)(car pattern))(pattern (cdr pattern)(cdr pattern)))
  586.         ((null op))
  587.         (force-print op)
  588.         (pcond
  589.          ((consp op)
  590.              (csetq nargs (append nargs `(,(car op))))
  591.              (csetq body (cons (cons 'trace-initvar op) body)))
  592.          ((string-member op '(&key &aux))
  593.              (csetq nargs (append nargs `(&rest lkeys)))
  594.              (csetq body `((KeyLET ,pattern ,@body)))
  595.              (csetq pattern ()))
  596.          (t (csetq nargs (append nargs (list op))))))
  597.       (break)
  598.                (force-print body)
  599.       (punless (consp body) (pwhen body (print body) (break "translate-varblock bodyIn was not list")))
  600.        (ret
  601.            (clet ((trace `(list ',name ,@(mapcar #'var-traceable nargs))))
  602.                (force-print trace)
  603.           `( (,@nargs)
  604.                  (clet ((*funcall-form* ,trace) (*trace-stack* (cons *funcall-form* *trace-stack*)))
  605.                       (ret (trace-progn (trace-format :funcall "lexical:: ~s" *funcall-form*) ,@body))))))))
  606.  
  607.  
  608. (sl::defmacro shadow-defun (package name &rest args-body)
  609.  ;;  (force-print (list 'shadow-defun (describe-symbol name) package))
  610.     (clet ((cl (make-shadow name package)))
  611.       (ret `(define ,cl ,@(translate-varblock cl (car args-body) (cdr args-body))))))
  612.  
  613. (sl::defmacro shadow-macro (package name &rest args-body)
  614.   ;;(pwhen (consp name)(null name)(csetq package *PACKAGE* name package args-body  (cons name args-body)))
  615.    (force-print (list 'shadow-macro (describe-symbol name) package))
  616.     (clet ((cl (make-shadow name package)))
  617.       (ret `(sl::defmacro ,cl ,@(translate-varblock cl (car args-body)(cdr args-body))))))
  618.  
  619. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  620. ;; TRANSLATION for CL to SUBL - Some of the features of the system must be accessable from everywhere
  621. ;; Like the
  622. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  623. (defvar *caller-pattern-table* (SL::make-hash-table 23 #'equal) "Stores patterns for function destructuring.")
  624.  
  625. (define lookup-caller-pattern (name) (ret (gethash name *caller-pattern-table*)))
  626. ;;(translate-block bodyIn 'form  name)))
  627.  
  628. (define string-member (item list)
  629.    (ret (member-if  #'(lambda (ele) (ret (STRING-EQUAL (nstring ele) (nstring item)))) list)))
  630.  
  631. (define FIND-ALL-SYMBOLS (name &rest lkeys)
  632.     (KEYLET ((use (LIST-ALL-PACKAGES)) results (test #'true)(test-not #'null))
  633.        (cdolist (pack use)
  634.          (clet ((sym (find-symbol (string name) pack)))
  635.           (pwhen sym (pwhen (funcall test sym) (csetq results (cons sym results))))))
  636.        (ret results)))
  637.  
  638. (define translate-function-expression (form)
  639.   (clet ((vals (cmultiple-value-list (function-lambda-expression form))))
  640.     (punless (car vals) (rplaca vals (third vals)))
  641.     (ret (values vals))))
  642.  
  643. (define translate-block (form &optional (transkey 'form) name (environment nil) funcall)
  644.  (ret
  645.    (cond
  646.      ((SELF-EVALUATING-FORM-P form) form)
  647.      ((functionp form) (ret (list 'function (translate-block (translate-function-expression form) transkey name environment funcall))))
  648.      ((cor (keywordp form)(numberp form)(stringp form)) form)
  649.    ;;  ((member form *incompatable*)(ret (describe-symbol "SYS::" form)))
  650.      ((cor (null form)(equal (type-of form) 'filecomment)(atom form)(stringp form)(numberp form)) (ret form))
  651.      (t
  652.        (trace-progn
  653.         (clet ((op (car form))(cdrform (cdr form))(new-transkey (lookup-caller-pattern op)))
  654.           (pwhen (symbolp op)
  655.              (cond
  656.                ;;((string-member op '(sl::progn)) (ret `(trace-progn  ,@(mapcar #'(lambda (item) (ret (translate-block item 'form name ))) cdrform))))
  657.                ((string-member op '("defun" define))                  
  658.                   (ret (cons op (cons (translate-block (car cdrform))
  659.                        (translate-varblock (translate-block (car cdrform)) (car (cdr cdrform)) (cdr (cdr cdrform)))))))
  660.                        ;;(translate-varblock (translate-block (car cdrform)) (car (cdr cdrform)) `((ret (sl::progn ,@(cdr (cdr cdrform))))))))))
  661.                ((string-member op '(lambda))    ;; name     transkey         body
  662.                   (ret (cons op (translate-varblock (gensym) (car cdrform)(cdr cdrform)))))))
  663.  
  664.             (ret (mapcar #'(lambda (x) (ret (translate-block x 'form name))) form))))))))
  665.  
  666.  
  667.  
  668. (define describe-package (&optional (package *PACKAGE*))
  669.       (csetq package (coerce-package package))
  670.       (clet ((reference (intern (package-name package)))
  671.               (inherited (intern "inherited" package))
  672.               (internal (intern "internal" package))
  673.               (external (intern "external" package)))    
  674.             (csetf (symbol-value external) ())
  675.             (csetf (symbol-value internal) ())
  676.             (csetf (symbol-value inherited) ())
  677.             (CDO-ALL-SYMBOLS (sym package)
  678.              (clet ((name (symbol-name sym)))
  679.                (cmultiple-value-bind (suggest cstatus) (find-symbol name package)
  680.                 (pwhen suggest
  681.                   (csetq suggest (list name (package-name (symbol-package suggest))))
  682.                         (pcase cstatus
  683.                             (:internal (cpush suggest (symbol-value internal) #'equal))
  684.                             (:inherited (cpush suggest (symbol-value inherited) #'equal))
  685.                             (:external (cpush suggest (symbol-value external) #'equal))
  686.                             (otherwise))))))
  687.        (ret (csetf (symbol-value reference)
  688.           (print `(:type ,(type-of package)
  689.                   :name ,(package-name package)
  690.                   :nicknames ,(package-nicknames package)
  691.                   :package-use-list ,(package-use-list package)
  692.                   :package-used-by-list ,(package-used-by-list package)
  693.                   :package-shadowing-symbols ,(package-shadowing-symbols package)
  694.                  (:internal ,(length (symbol-value internal)))
  695.                  (:external ,(length (symbol-value external)))
  696.                  (:inherited ,(length (symbol-value inherited)))))))))
  697.  
  698. ;;(describe-package :SYS)
  699. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  700. ;; Define shadow functions and macros
  701. ;;
  702. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  703.  
  704.  ;; (lock-package :SYSTEM)
  705. ;;; Shadow  --  Public
  706. ;;;
  707. ;;;
  708. (define shadow (suggest &optional (package *package*))
  709.   "Make an internal symbol in Package with the same name as each of the
  710.  specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
  711.  If a symbol with the given name is already present in Package, then
  712.  the existing symbol is placed in the shadowing symbols list if it is
  713.  not already present."
  714.  (clet ((name (symbol-name suggest))(package (coerce-package package)))
  715.    (cmultiple-value-bind (s w) (find-symbol name package)
  716.     (pwhen (cor (cnot w) (eq w :inherited))
  717.        (csetq s (make-symbol name))
  718.        (intern s package))
  719.      (shadowing-import package s)))
  720.     (ret t))
  721.  
  722.  
  723. ;;; shadowing-import  --  Public
  724. ;;;
  725. ;;;    If a conflicting symbol is present, unintern it, otherwise just
  726. ;;; stick the symbol in.
  727. ;;;
  728. (define shadowing-import (sym &optional (package *package*))
  729.   "Import Symbols into package, disregarding any name conflict.  If
  730.  a symbol of the same name is present, then it is uninterned.
  731.  The symbols are added to the Package-Shadowing-Symbols."
  732.   (clet ((package (coerce-package package)))
  733.       (cmultiple-value-bind (s w) (find-symbol (symbol-name sym) package)
  734.         (punless (cand w (cnot (eq w :inherited)) (eq s sym))
  735.           (pwhen (cor (eq w :internal) (eq w :external))
  736.             ;;
  737.             ;; If it was shadowed, we don't want Unintern to flame out...
  738.             ;;(csetq *all-shadowing-symbols* (remove (cons package s)))
  739.             (unintern s package))
  740.       (intern sys package))
  741.     (shadowing-import package sym)))
  742.   (ret t))
  743.  
  744.  
  745. ;;(punless (fboundp 'defmethod) (defmacro  #>SYS::defmethod (name pattern &rest body)(ret `(defun ',name ',pattern ,@body))))
  746.  
  747.   #|
  748.  
  749.  
  750.  
  751. *CANONICALIZE-CLAUSE-SENTENCE-TERMS-SENSE-LAMBDA* value: NIL
  752. *CONTAINING-SUBEXPRESSIONS-LAMBDA-TERM* value: NIL
  753. *INVALID-LAMBDA-LIST-MESSAGE* value: Lambda list ~S of method ~S of interface ~S is not a valid lambda list.
  754. *MERGE-DNF-LAMBDA-VAR* value: NIL
  755. *POSITION-IF-BINARY-LAMBDA-ARG2* value: NIL
  756. *POSITION-IF-BINARY-LAMBDA-FUNC* value: NIL
  757. *RBP-LAMBDA-LAYER* value: NIL
  758. *RKF-IRRELEVANT-TERM-LAMBDA-DOMAIN-MT* value: NIL
  759. *RULE-DNF-LAMBDA-VAR* value: NIL
  760. *TACTIC-STRATEGIC-PRODUCTIVITY-AND-COMPLETENESS-WORSE-LAMBDA-STRATEGY* value: NIL
  761. *UIA-IRRELEVANT-PRECISION-SUGGESTION-LAMBDA-AGENDA* value: NIL
  762. *UIA-IRRELEVANT-PRECISION-SUGGESTION-LAMBDA-MT* value: NIL
  763. API-APPLY-LAMBDA [function] (REQ-0 REQ-1)
  764.  
  765.  
  766. (API-APPLY-LAMBDA '(&rest r) '(1 2 3))
  767.  
  768. AR-PHRASE-DIVIDE-EQ-BEST-LAMBDA-SUBSTITUTE [function] (REQ-0)
  769. CLASSES-LAMBDA-LIST-GIVEN-METHOD-DECL [function] (REQ-0)
  770. CLASSES-VALID-LAMBDA-LIST-P [function] (REQ-0)
  771. CONTAINING-SUBEXPRESSIONS-LAMBDA-FN [function] (REQ-0)
  772. CYC-LAMBDA [function] (&OPTIONAL OPT-0 OPT-1 OPT-2 OPT-3 OPT-4 OPT-5)
  773. EVAL-IN-API-USER-LAMBDA-FN? [function] (REQ-0)
  774. FILTERED-LAMBDA-LIST unbound
  775. function-expression [function] (REQ-0)
  776. GENERALITY-SORT-LAMBDA [function] (REQ-0)
  777. KBQ-FILTER-QUERY-SET-RUN-TO-QUERIES-LAMBDA [function] (REQ-0)
  778. KBQ-FILTER-QUERY-SET-RUN-TO-QUERIES-NOT-LAMBDA [function] (REQ-0)
  779. KCT-FILTER-TEST-SET-RUN-TO-TESTS-LAMBDA [function] (REQ-0)
  780. KCT-FILTER-TEST-SET-RUN-TO-TESTS-NOT-LAMBDA [function] (REQ-0)
  781. LAMBDA-EXPRESSION? [function] (REQ-0)
  782. LAMBDA-FUNCTION-ARITY [function] (REQ-0)
  783. LAMBDA-FUNCTION-EXPRESSION [function] (REQ-0)
  784. LAMBDA-FUNCTION-FORMAL-ARGS [function] (REQ-0)
  785. LAMBDA-FUNCTION-P [function] (REQ-0)
  786. LAMBDA-LIST unbound
  787. LAMBDA-SUBEVENT? [function] (REQ-0)
  788. LAMBDA-SYNTAX-P [function] (REQ-0)
  789. METHOD-LAMBDA-LIST [function] (REQ-0)
  790. METHOD-LISTENERS-FILTERED-LAMBDA-LIST [function] (REQ-0 REQ-1)
  791. METHODS-FILTER-OPTION-WORDS-FROM-LAMBDA-LIST [function] (REQ-0)
  792. METHODS-LAMBDA-LIST-TO-LISTED-ARG-VALUE-EXPRESSION [function] (REQ-0)
  793. OBJECT-METHOD-LAMBDA-LIST-METHOD [function] (REQ-0 REQ-1)
  794. POSITION-IF-BINARY-LAMBDA [function] (REQ-0)
  795. RBP-RB-LAYER-EXEMPT-RULE-LAMBDA? [function] (REQ-0)
  796. REMOVAL-LAMBDA [function] (REQ-0)
  797. RKF-IRRELEVANT-TERM-LAMBDA? [function] (REQ-0)
  798. UIA-IRRELEVANT-PRECISION-SUGGESTION-TERM-LAMBDA? [function] (REQ-0)
  799. _CSETF-METHOD-LAMBDA-LIST [function] (REQ-0 REQ-1)
  800. FUNCTOR-IN-BODY-P  (SYMBOL BODY)
  801. SUBL-NON-VARIABLE-NON-KEYWORD-SYMBOL-P
  802. SUBL-NON-VARIABLE-SYMBOL-P
  803. SUBL-PERFORMATIVE-P
  804.  
  805.  
  806. EVERY-NTH  (N LIST)
  807.  
  808.  
  809. ARGS-FROM-ARG-LIST  
  810.  
  811.  
  812.  DEFINE-API-OBSOLETE
  813.  
  814.  TRANSLATOR-RET-OPTIMIZE-BODY
  815.  TRANSLATE-FORM-EXPANSION-FACTOR       
  816. FUNCTOR-IN-EXPRESSION-P  (FUNCTOR EXPRESSION)
  817.     (csetq packname (package-name (csetq package (coerce-package *PACKAGE*))))
  818.   |#
  819.  
  820.  
  821. ;;based on (sethash key table value)
  822. (defmacro catch (tag &rest body)
  823.  (ret `(apply #'values
  824.         (clet ((*thrown* :unthrown)
  825.            (*result* :unevaled))
  826.            (ccatch ,tag *thrown* (csetq *result* (multiple-value-list (trace-progn  ,@body))))
  827.            (fif (equal *result* :unevaled) (list *thrown*) *result*)))))
  828.  
  829. (define map-sequences (function sequences)
  830.  (ret (fif
  831.     (member () sequences) ()
  832.     (cons (apply function (mapcar #'car sequences))
  833.        (map-sequences function (mapcar #'cdr sequences))))))
  834.  
  835. (define map (result-type function &rest sequences)
  836.  (ret (fif result-type (coerce (map-sequences function sequences) result-type)
  837.     (sl::progn (map-sequences function sequences) nil))))
  838.  
  839.  
  840. (define concatenate (cltype &rest pattern) (ret `(coerce (cconcatenate ,@pattern) ,cltype)))
  841. (define string-concat (&rest list)  (ret (apply #'cconcatenate (cons "" (flat-string (flatten list))))))
  842. (define concat (&rest list)(ret (apply #'cconcatenate (cons "" (mapcar (lambda (x)(ret (fif (stringp x) x (coerce x 'string) ))) list)))))
  843. (define string-concat (&rest list)(ret (apply #'cconcatenate (cons "" (mapcar #'(lambda (x) (ret (fif (stringp x) x (coerce x 'string) ))) list)))))
  844. (defmacro string-concat (&rest list) (ret `(cconcatenate ,@list)))
  845. (define string-concat (&rest list)(ret (apply #'cconcatenate (cons "" (mapcar #'(lambda (x)(ret (fif (stringp x) x (coerce x 'string) ))) list)))))
  846.  
  847. (define same-classes (current target) (ret (equal current target)))
  848. (defvar *coerce-methods* (sl::make-hash-table 32))
  849. (define coerce (value result-type &optional (subclassfn #'same-classes))
  850.  (clet ((vtype (type-of value))
  851.      (len value)
  852.      (cltype result-type)
  853.      (howto (gethash result-type *coerce-methods*)))
  854.  
  855.      (pwhen (equal result-type vtype) (ret value))
  856.      (pwhen howto
  857.       (sl::progn
  858.        (csetq howto (pcond ((assoc vtype howto subclassfn))((assoc 't howto))))
  859.        (pwhen howto
  860.         (ret (sl::eval
  861.          `(clet ((value ',value)(result-type ',result-type)(vtype ',vtype))
  862.            ,(cdr howto)))))))
  863.  
  864.     (funless (cand (consp cltype)
  865.            (csetq len (second cltype))
  866.            (csetq cltype (car cltype)))
  867.      (fif
  868.       (consp value)
  869.       (csetq len (length value))))
  870.     (pcase cltype ('t (ret value))
  871.         ('sequence
  872.         (fif
  873.          (sequencep value)
  874.          (ret (copy-seq value))
  875.          (csetq value (write-to-string value)))
  876.         (csetq cltype (make-vector len))
  877.         (cdo ((idx 0 (+ 1 idx)))
  878.            ((= idx len)
  879.            (ret cltype ))
  880.            (set-aref cltype idx (elt value idx))))
  881.         ('character
  882.         (pcond
  883.          ((characterp value)
  884.          (ret value))
  885.          ((numberp value)
  886.          (ret (code-char value)))
  887.          ((stringp value)
  888.          (ret (char value 0)))
  889.          (t (ret (char (coerce value 'string ) 0)))))
  890.         ('number
  891.         (pcond
  892.          ((numberp value)
  893.          (ret value))
  894.          ((characterp value)
  895.          (ret (char-code value)))
  896.          ((stringp value)
  897.          (ret (string-to-number value)))
  898.          (t (ret (string-to-number (write-to-string value))))))
  899.         ('integer (ret (round (coerce value 'number))))
  900.         ('fixnum (ret (round (coerce value 'number))))
  901.         ('float (ret (float (coerce value 'number))))
  902.         ('real (ret (float (coerce value 'number))))
  903.         ('flonum (ret (float (coerce value 'number))))
  904.         ('string
  905.         (pcond
  906.          ((stringp value)
  907.          (ret value))
  908.          ((characterp value)
  909.          (ret (make-string 1 value)))
  910.          ((sequencep value)
  911.          (csetq cltype (make-string len))
  912.          (cdo ((idx 0 (+ 1 idx)))
  913.             ((= idx len)
  914.             (ret cltype ))
  915.             (set-aref cltype idx (coerce (elt value idx) 'character))))
  916.          (t (ret (write-to-string value)))))
  917.         ('list
  918.         (pcond
  919.          ((listp value)
  920.          (ret list))
  921.          ((sequencep value)
  922.          (csetq cltype nil)
  923.          (cdo ((idx len (- idx 1)))
  924.             ((= idx 0)
  925.             (ret cltype ))
  926.             (csetq cltype (cons (elt value idx) cltype))))
  927.          (t (csetq cltype nil)
  928.           (csetq value (write-to-string value))
  929.           (cdo ((idx len (- idx 1)))
  930.              ((= idx 0)
  931.              (ret cltype ))
  932.              (csetq cltype (cons (elt value idx) cltype))))))
  933.         ('cons
  934.         (pcond
  935.          ((listp value)
  936.          (ret list))
  937.          ((sequencep value)
  938.          (csetq cltype nil)
  939.          (cdo ((idx len (- idx 1)))
  940.             ((= idx 0)
  941.             (ret cltype ))
  942.             (csetq cltype (cons (elt value idx) cltype))))
  943.          (t (csetq cltype nil)
  944.           (csetq value (write-to-string value))
  945.           (cdo ((idx len (- idx 1)))
  946.              ((= idx 0)
  947.              (ret cltype ))
  948.              (csetq cltype (cons (elt value idx) cltype))))))
  949.         ('keypair
  950.         (pcond
  951.          ((atom value)
  952.          (ret list value))
  953.          (t (ret (coerce value 'cons)))))
  954.         ('alist (csetq cltype (csetq cltype nil))
  955.         (fif
  956.          (sequencep value) t (csetq value (coerce value 'sequence)))
  957.         (cdo ((idx 0 (+ 1 idx)))
  958.            ((= idx len)
  959.            (ret cltype))
  960.            (csetq result-type (coerce (elt value idx) 'cons))
  961.            (csetq cltype (acons (car result-type)
  962.                      (cdr result-type) cltype)))
  963.         (ret cltype))
  964.         ('hash-table
  965.         (fif
  966.          (hash-table-p value)
  967.          (ret value))
  968.         (csetq cltype (sl::make-hash-table len))
  969.         (fif
  970.          (sequencep value) t (csetq value (coerce value 'sequence)))
  971.         (cdo ((idx 0 (+ 1 idx)))
  972.            ((= idx len)
  973.            (ret cltype))
  974.            (print (list 'coerce value result-type cltype len (elt value idx)))
  975.            (csetq result-type (coerce (elt value idx) 'keypair))
  976.            (sethash (car result-type) cltype (cdr result-type))))
  977.         (otherwise (ret value)))
  978.     (throw :coerce (list value result-type)))
  979.  (ret value))
  980.  
  981.  
  982. (defmacro defcoerce (to from &rest body)
  983.  "the body assumes bindings will be present for value vtype result-type and howto. (car howto) will yeild the original from durring defcoerce
  984. example:: (defcoerce string t (string value))
  985. (car howto) = > t
  986. so that the (coerce #\a 'string ) procedure can know that vtype when character was found as a subclass of t"
  987.   (ret `(sethash ',to *coerce-methods* (acons ',from '(sl::progn ,@body) (gethash ',to *coerce-methods*)))))
  988.  
  989. (print '(load "common.lisp")) (terpri)
  990. (punless (sl::member :CYC-COMMON-LISP sl::*features*)
  991.    (force-print '(LOAD "common-lisp.lisp"))
  992.    (fif (cand nil (sl::yes-or-no-p) )
  993.     (progn
  994.        (cyc::USE-PACKAGE '(:CYC :SL) :SYSTEM
  995.        (cpushnew :CYC-COMMON-LISP sl::*features*))
  996.        (defcoerce chew t (cconcatenate (string value) "-chew"))
  997.        (print (coerce "stringy" 'chew))
  998.     ;;   (in-package "SYSTEM"))
  999.     )
  1000.     (progn
  1001.        (CDO-SYMBOLS (sym *SUBLISP-PACKAGE*) (export sym *SUBLISP-PACKAGE*))
  1002.        (CDO-SYMBOLS (sym *CYC-PACKAGE*) (export sym *CYC-PACKAGE*))
  1003.        (defcoerce chew t (cconcatenate (string value) "-chew"))
  1004.        (print (coerce "stringy" 'chew)))))
  1005.   ;;     (in-package "INT"))))
  1006.  
  1007.  
  1008. ;;(in-package "LISP")
  1009. ;;(import-in-all (best-symbol '(make-shadow defun shadow-defun shadow-macro defun shadow-operator)))
  1010.  
  1011. ;;(make-shadow '(PROGN MAKE-HASH-TABLE LOAD STRING-DOWNCASE MAKE-STRING LOOP ) :SYS)
  1012. ;;(defun #>SYS::string-downcase (str) (sl::string-downcase (string str)))
  1013.  
  1014. ;;(make-shadow 'define :SYS)
  1015. (sl::defmacro #>SYS::cl-define (suggest pattern &rest body)
  1016.      (ret `(trace-progn (sl::define ,suggest ,@(translate-varblock suggest pattern body)))))
  1017.  
  1018. (sl::defmacro defun (suggest pattern &rest body)
  1019.      (ret `(trace-progn (sl::define ,suggest ,@(translate-varblock suggest pattern body)))))
  1020.  
  1021.  
  1022.  
  1023. ;;(make-shadow 'lambda :SYS)
  1024. ;;(sl::defmacro cl::lambda (pattern &rest body) (ret `(sl::lambda ,pattern (ret (trace-progn ,@body)))))
  1025.  
  1026. ;;(make-shadow #>SYS::defstruct :SYS)
  1027. (sl::define #>SYS::defstruct (name &rest rest)
  1028.    (clet ((slots  (mapcar #'(lambda (x)
  1029.                 (ret (fif (atom x) x (car x)))) rest)))
  1030.     `(sl::defstruct (,name) ,@slots)))
  1031.  
  1032. ;;(SYS::defstruct filecomment start end src block-p)
  1033.  
  1034. ;;;(in-package "CL")
  1035.  
  1036. (defvar *incompatable* '(create-instance isa all-instances comment arity load-kb
  1037.  cdefmacro SYS::flatten assoc-equal ordered-set-difference ordered-intersection quotify permute trim-whitespace first-char
  1038.  last-char ends-with starts-with string-to-number read make-string cdefmacro string-downcase make-hash-table
  1039.  loop intersection defstruct equal member remove remove-duplicates delete-duplicates subsetp))
  1040.  
  1041. (define SYS::make-package (name &rest lkeys)
  1042.    (KeyLET ((use *default-package-use*) nicknames)
  1043.     (force-print `(SYS::make-package ,name ,use ,nicknames))
  1044.      (ret (cyc::eval (force-print
  1045.        `(sl::make-package ,name
  1046.                ',(reverse (mapcar #'package-name (mapcar #'coerce-package use)))
  1047.                ',(mapcar #'SYS::make-keyword nicknames)))))))
  1048.  
  1049. #|
  1050.  
  1051. #> CL 'EWRT
  1052. ;;(in-package (package-name savepack))
  1053.  
  1054. (find-symbol "READ" :SYS)
  1055. (csetq sym  (make-symbol "PCOND"))
  1056. (import sym :SYS)
  1057. (intern "PCOND" :SYS)
  1058. (find-symbol "PCOND" :SYS)
  1059.  
  1060. (intern (make-symbol "ACONS") :SYS)
  1061. (find-symbol "ACONS" :SYS)
  1062.  
  1063. (shadow-macro CL read (&rest body) (ret (cons 'SL::read  body)))
  1064. (print '(shadow-macro CL sl::eval (&rest body) (ret (cons 'SL::eval  body))))
  1065.  
  1066. (define SYS::read (&rest body)      
  1067.   (terpri)
  1068.   (ret (cons 'sl::read  body)))
  1069.  
  1070. |#
  1071.  
  1072. (sl::defmacro shadow-operator (package name &optional (other name) (callpattern '(body) ) (varpattern `(&rest ,@callpattern)))
  1073.     (clet ((cl (make-shadow name package)))      
  1074.         (print cl)
  1075.         (ret (print `(sl::defmacro ,cl ,varpattern (ret (cons ',other ,@callpattern)))))))
  1076.  
  1077. (shadow-operator :CL push cpush)
  1078. (shadow-operator :SYS svref aref)
  1079. (shadow-operator :SYS vset set-aref)
  1080. (shadow-operator :SYS incf cinc)
  1081. (shadow-operator :SYS decf cdec)
  1082. (shadow-operator :SYS not cnot)
  1083.  
  1084. (shadow-operator :CYC push cpush)
  1085. (shadow-operator :CYC svref aref)
  1086. (shadow-operator :CYC vset set-aref)
  1087. (shadow-operator :CYC incf cinc)
  1088. (shadow-operator :CYC decf cdec)
  1089. (shadow-operator :CYC not cnot)
  1090.  
  1091. ;;(shadow-operator :SYS progn trace-progn)
  1092. ;;(shadow-operator :SYS char-int char-code)
  1093.  
  1094.  
  1095. ;;(shadow-macro SYS::apply (fn &rest body) (ret `(apply ,fn ,@body)))
  1096.  
  1097. ;;(export '(SYS::load like-funcall 'eval ))
  1098. #|
  1099. #+CRISPY
  1100. '(defun #>SYS::eval (code)
  1101.     (force-print `(sl::eval ,code))
  1102.     (ret (SL::eval `(trace-progn ,code))))
  1103.  
  1104. ;;(defmacro  #>SYS::handler-case (form &rest cases) (print (list 'handler-case form cases)) (ret `,form))
  1105.  
  1106. (csetq  *load-verbose* t)
  1107. (csetq *load-print* t)
  1108.  
  1109. #+CRISPY
  1110. (defun #>SYS::load (filespec &rest lkeys)
  1111.  (KeyLet (verbose print if-does-not-exist external-format)
  1112.   (SL::clet ((*standard-input* (SL::OPEN-TEXT filespec :input)))
  1113.     (cdo () ()
  1114.     (clet ((expr (SL::read *standard-input* nil :EOF)))
  1115.      (pwhen (equal expr :EOF)
  1116.         (SL::close *standard-input*)
  1117.         (ret T))
  1118.       (SYS::eval expr))))))
  1119.  
  1120. |#
  1121. ;;(defmacro  #>SYS::defstub (feat symb &optional default) `(define ,symb (&rest body) (format t "~s~%" (cons ',feat (cons ',symb body))) ,default))
  1122.  
  1123. #|
  1124.  
  1125. '(defmacro  #>SYS::go (label)
  1126.  (clet ((name (label-to-functionname label)))
  1127.   `(throw ,name #',name)))
  1128.  
  1129. '(defmacro  #>SYS::tagbody (&body body)
  1130.     "The emulation of tagbody/go by catch/throw is considerably less obvious than the emulation of block/return-from.
  1131.    This is because tagbody defines a number of different labels rather than a single block name, and because the parsing of the
  1132.    tagbody body is considerably more complicated. The various segments of the tagbody are emulated by a labels nest of mutually
  1133.    recursive functions, which are forced to all execute at the correct dynamic depth by means of a
  1134.    'trampoline. If the implementation implements the 'tail recursion' optimization for functions
  1135.    which have no arguments and return no values, and if the simpler cases of go's are optimized away, then this emulation can be quite efficient."
  1136.              (clet ((init-tag (gensym)) (go-tag (gensym)) (return-tag (gensym))
  1137.                    
  1138.                     (functions
  1139.                      (mapcon
  1140.                          #'(lambda (seq &aux (label (car seq) (s (cdr seq)))
  1141.                                         (when (atom label)
  1142.                                           (let ((p (position-if #'atom s)))
  1143.                                             `((,(label-to-functionname label) ()
  1144.                                                  ,@(subseq s 0 (or p (length s)))
  1145.                                                  ,(if p `(,(label-to-functionname (elt s p)))
  1146.                                                     `(throw ,return-tag 'nil)))))))
  1147.                              `(,init-tag ,@body))))
  1148.                     `(let* ((,go-tag (list nil)) (,return-tag (list nil))
  1149.                                                  ,@(mapcar #'(lambda (f) `(,(car f) ,go-tag)) functions))
  1150.                        (catch ,return-tag
  1151.                               (labels ,functions
  1152.                                 (let ((nxt-label #',(caar functions)))
  1153.                                   (loop (csetq nxt-label (catch ,go-tag (funcall nxt-label)))))))))))
  1154.  
  1155.  
  1156. (defmacro  #>SYS::labels (fns &body forms)
  1157.              "CIRCULAR ENVIRONMENTS OF 'LABELS EMULATED BY 'FLET AND 'SETQ: It is generally believed that the circular environments of labels cannot be
  1158.    obtained by means of flet. This is incorrect, as the following emulation (reminiscent of Scheme) shows.
  1159.    With a more sophisticated macro-expansion, this emulation can be optimized into production-quality code."
  1160.              (let* ((fnames (mapcar #'car fns))
  1161.                     (nfnames (mapcar #'(lambda (ignore) (gensym)) fnames))
  1162.                     (nfbodies (mapcar #'(lambda (f) `#'(lambda ,@(cdr f))) fns)))
  1163.                `(let ,(mapcar #'(lambda (nf) `(,nf #'(lambda () ()))) nfnames)
  1164.                   (flet ,(mapcar #'(lambda (f nf) `(,f (&rest a) (apply ,nf a)))
  1165.                            fnames nfnames)
  1166.                     (flet ,fns
  1167.                       (sl::progn ,@(mapcar #'(lambda (f nf) `(csetq ,nf #',f))
  1168.                                  fnames nfnames))
  1169.                       ,@forms)))))
  1170.  
  1171. |#
  1172. ;;(defmacro  #>SYS::loop (&rest body) (ret `(loop ,@body)))
  1173. #|
  1174. ;;;; CLtL2 and ANSI CL Compatibility
  1175.  
  1176. (defmacro  #>SYS::loop (&rest exps)
  1177.  ;;"supports both ansi and simple loop. warning:: not every loop keyword is supported."
  1178.  (format t "~%~s~%" `(SL::loop ,@exps))(force-output)
  1179.  (punless (member-if #'symbolp exps) (ret `(loop ,@exps)))
  1180.  (pcase (car exps)
  1181.    ((until while) (ret exps))
  1182.    (for ;;(SYS::loop-for (cdr exps)))
  1183.     (break "SYS::loop-for"))
  1184.    (repeat (break "SYS::loop-repeat"))
  1185.    (otherwise (ret `(SL::loop ,@exps))))
  1186.  
  1187. '(defmacro  #>SYS::loop-for (var from-in start/list &rest exps)
  1188.   (pcase
  1189.     from-in
  1190.     (from (SYS::loop-for-from var start/list))))
  1191.  
  1192.  
  1193. ;; some tests
  1194. '(print (translate-block '
  1195.  (defun #>SYS::member (item list &key (test #'eql)(key #'identity) test-not)
  1196.    (pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))  
  1197.    (member item list test key))))
  1198. |#
  1199.  
  1200. (sl::defmacro defun (name pattern &rest body)  
  1201.    ;;(force-print (list 'defun (describe-symbol name) pattern body))
  1202.    (ret `(trace-progn (sl::define ,name ,pattern (ret (trace-progn ,@body))))))
  1203.  
  1204. (sl::defmacro #>CL::defmacro (name pattern &rest body)  
  1205.    ;;(force-print (list 'defun (describe-symbol name) pattern body))
  1206.    (ret `(trace-progn (sl::defmacro ,name ,pattern (ret (trace-progn ,@body))))))
  1207.  
  1208.  
  1209.  
  1210. (macroexpand-1 '(defun #>SYS::make-string (size &rest lkeys)
  1211.  (clet (element-type initial-element initial-contents)
  1212.         (init-keyval initial-element #\space)
  1213.   (ret (SL::make-string size initial-element)))))
  1214.  
  1215. (defun #>SYS::make-string (size &rest lkeys)
  1216.  (clet (element-type initial-element initial-contents)
  1217.         (init-keyval initial-element #\space)
  1218.   (ret (SL::make-string size initial-element))))
  1219.  
  1220. (defun #>SYS::make-hash-table (&rest lkeys)
  1221.  (clet (test size rehash-size rehash-threshold)
  1222.   (init-keyval size 64)(init-keyval test #'eql)
  1223.   (ret (SL::make-hash-table size test))))
  1224.  
  1225. ;; barely started coding
  1226. (defun #>SYS::make-array (dimensions &rest lkeys)
  1227.  (clet (element-type initial-element initial-contents adjustable fill-pointer displaced-to displaced-index-offset)
  1228.   (init-keyval initial-element)
  1229.   (ret (SL::make-vector dimensions initial-element))))
  1230.  
  1231. ;; barely started coding
  1232. (defun #>SYS::array-dimensions (array subdim)
  1233.   (ret (pcase
  1234.     subdim
  1235.     (0 (length array)
  1236.     (t (length (nth subdim array)))))))
  1237.  
  1238.  
  1239. ;;(SYS::defun force-print (stuff) (print stuff) (force-output) stuff)
  1240. (force-print "this is not really cl!")
  1241. ;;(macroexpand '(defun force-print (stuff) (print stuff) (force-output)stuff))
  1242. ;;(macroexpand '(trace-progn 'MYPRINT (STUFF) (PRINT STUFF) (FORCE-OUTPUT) STUFF))
  1243. ;;(macroexpand '(trace-progn  (PRINT STUFF) (FORCE-OUTPUT) STUFF))
  1244. (define structure-slot (object slot)
  1245.    (ret (pcond
  1246.        ((structurep object) (sl::_structure-slot object slot)))))
  1247.  
  1248. (define set-structure-slot (object slot value)
  1249.    (ret (pcond
  1250.        ((structurep object) (sl::_set-structure-slot object slot value)))))
  1251.  
  1252. #|
  1253. (sl::progn
  1254.  (defconstant *dtp-delay* 'delay)
  1255.  
  1256.  (defun #>SYS::delay-p (SL::object)
  1257.   (ret (cand (SL::_structures-bag-p SL::object)
  1258.         (eq (SL::_structure-slot SL::object 1) *dtp-delay*))))
  1259.  
  1260.  (defun #>SYS::delay-value (SL::object)
  1261.   (check-type SL::object delay-p)
  1262.   (ret (SL::_structure-slot SL::object 2)))
  1263.  
  1264.  (defun #>SYS::delay-function (SL::object)
  1265.   (check-type SL::object delay-p)
  1266.   (ret (SL::_structure-slot SL::object 3)))
  1267.  
  1268.  (defun #>SYS::_csetf-delay-value (SL::object SL::value)
  1269.   (check-type SL::object delay-p)
  1270.   (ret (SL::_set-structure-slot SL::object 2 SL::value)))
  1271.  
  1272.  (defun #>SYS::_csetf-delay-function (SL::object SL::value)
  1273.   (check-type SL::object delay-p)
  1274.   (ret (SL::_set-structure-slot SL::object 3 SL::value)))
  1275.  (SL::_def-csetf 'delay-value '_csetf-delay-value)
  1276.  (SL::_def-csetf 'delay-function '_csetf-delay-function)
  1277.  
  1278.  (defun #>SYS::make-delay (&optional SL::arglist)
  1279.   (clet ((SL::new (SL::_new-structure *dtp-structures-bag* 2)))
  1280.      (SL::_clear-sub-structure SL::new 2 *dtp-delay*)
  1281.      (clet ((#::next SL::arglist))
  1282.         (loop
  1283.          (fif
  1284.           #::next
  1285.          
  1286.           (clet ((#::current-arg (car #::next))
  1287.              (#::current-value (cadr #::next)))
  1288.              (pcase #::current-arg
  1289.                 (:value (_csetf-delay-value SL::new #::current-value))
  1290.                 (:function (_csetf-delay-function SL::new #::current-value))
  1291.                 (otherwise (error (format nil "invalid slot ~s for construction function" #::current-arg))))
  1292.              (csetq #::next (cddr #::next)))
  1293.           (ret SL::new))))
  1294.      (ret SL::new)))
  1295.  (identity 'delay))
  1296.  
  1297. |#
  1298.  
  1299.  
  1300. #|
  1301. Function MAP-INTO (still writing also require the array stuff way below)
  1302.  
  1303. Syntax::
  1304.  
  1305. map-into result-sequence function &rest sequences => result-sequence
  1306.  
  1307. Arguments and Values::
  1308.  
  1309. result-sequence--a proper sequence.
  1310. function--a designator for a function of as many arguments as there are sequences.
  1311. sequence--a proper sequence.
  1312.  
  1313. Description::
  1314.  
  1315. Destructively modifies result-sequence to contain the results of applying function to each element in the argument sequences in turn.
  1316.  
  1317. Examples::
  1318.  
  1319.  (setq a (list 1 2 3 4) b (list 10 10 10 10)) => (10 10 10 10)
  1320.  (map-into a #'+ a b) => (11 12 13 14)
  1321.  a => (11 12 13 14)
  1322.  b => (10 10 10 10)
  1323.  (setq k '(one two three)) => (ONE TWO THREE)
  1324.  (map-into a #'cons k a) => ((ONE . 11) (TWO . 12) (THREE . 13) 14)
  1325.  (map-into a #'gensym) => (#::G9090 #::G9091 #::G9092 #::G9093)
  1326.  a => (#::G9090 #::G9091 #::G9092 #::G9093)
  1327.  
  1328. (defun #>SYS::map-into (result-sequence function &rest sequences)
  1329.  "Destructively set elements of RESULT-SEQUENCE to the results
  1330. of applying FUNCTION to respective elements of SEQUENCES."
  1331.  (clet ((arglist (make-list (length sequences)))
  1332.      (n (fif (listp result-sequence)
  1333.         most-positive-fixnum
  1334.         (array-dimension result-sequence 0))))
  1335.   ;; arglist is made into a list of pattern for each call
  1336.   ;; n is the length of the longest vector
  1337.   (pwhen sequences
  1338.    (csetf n (min n (SYS::loop for seq in sequencesminimize (length seq)))))
  1339.   ;; shadow-defun :SYS some shared functions::
  1340.   (clet
  1341.    ((*do-one-call*
  1342.     #'(lambda (i)
  1343.      (ret (cdolist (seq sequences)
  1344.         (cdolist (arg arglist)
  1345.         (cdo (fif (listp (first seq))
  1346.            (csetf (first arg)
  1347.               (pop (first seq)))
  1348.            (csetf (first arg)
  1349.               (aref (first seq) i))))))))
  1350.      (apply function arglist))
  1351.     (*do-result*
  1352.      #'(lambda (i)
  1353.      (ret (fif (cand (vectorp result-sequence)
  1354.          (array-has-fill-pointer-p result-sequence))
  1355.        (csetf (fill-pointer result-sequence)
  1356.           (max i (fill-pointer result-sequence))))))))
  1357.    ;; (declare (inline *do-one-call*))
  1358.    ;; Decide if the result is a list or vector,
  1359.    ;; and SYS::loop through each element
  1360.    (fif (listp result-sequence)
  1361.      (SYS::loop for i from 0 to (- n 1)
  1362.         for r on result-sequence
  1363.         do (csetf (first r)
  1364.              (*do-one-call* i))
  1365.         finally (*do-result* i))
  1366.      (SYS::loop for i from 0 to (- n 1)
  1367.         do (csetf (aref result-sequence i)
  1368.              (*do-one-call* i))
  1369.         finally (*do-result* i))))
  1370.    result-sequence))
  1371. |#
  1372.  
  1373. (defvar *complement-fns* (sl::make-hash-table 31) "defcomplement Hashtable to lookup how things like (complement #'member) might return")
  1374. (defun #>SYS::complement (fn)
  1375.  "If FN returns y, then (paip-complement FN) returns (not y)."
  1376.  (ret (pcond
  1377.    ((gethash fn *complement-fns*))
  1378.    (t #'(lambda (&rest pattern) (ret (cnot (apply fn pattern))))))))
  1379.  
  1380. ;; example:: (defcomplement < >=)
  1381. (defmacro  #>SYS::defcomplement (posfn negfn)
  1382.   (ret `(sl::progn (sethash #',posfn *complement-fns* #',negfn) (sethash #',negfn *complement-fns* #',posfn))))
  1383.  
  1384.  
  1385. ;; emits
  1386. ;;;;;;;;;;;;;;;;;  
  1387. (defun #>SYS::MEMBER (ITEM LIST &REST LKEYS)
  1388.  (RET
  1389.   (trace-progn  
  1390.   (CLET (TEST KEY TEST-NOT)
  1391.     (init-keyval KEY (FUNCTION IDENTITY)) (init-keyval TEST (FUNCTION EQL))
  1392.     (pWHEN TEST-NOT (SETQ TEST (FUNCTION (LAMBDA (X Y) (RET (CNOT (FUNCALL TEST-NOT X Y)))))))
  1393.     (MEMBER ITEM LIST TEST KEY)))))
  1394.  
  1395.  
  1396. '(print (translate-block '
  1397.  (defun #>SYS::intersection (list-1 list-2 &key (test #'eql)(key #'identity) test-not)
  1398.    (pwhen test-not (setq test #'(lambda (x y)(not (funcall test-not x y)))))
  1399.    (intersection list-1 list-2 test key))))
  1400.  
  1401. (defun #>SYS::intersection (list-1 list-2 &rest lkeys)
  1402.  (trace-progn 'SYS::intersection list-1 list-2 '&rest lkeys
  1403.  (clet (test key test-not)
  1404.     (init-keyval test)(init-keyval key)(init-keyval test-not)  
  1405.     (funless key (csetq key #'identity))
  1406.     (funless test (csetq test #'eql))
  1407.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1408.     (ret (intersection list-1 list-2 test key )))))
  1409.  
  1410.  
  1411. (defun #>SYS::remove (item list &rest lkeys )
  1412.  ;;(force-print `(SYS::remove ,item ,list &rest ,lkeys))
  1413.  (clet (test from-end test-not start end count key)
  1414.     (init-keyval test #'eql)(init-keyval key #'identity)(init-keyval test-not)(init-keyval from-end)(init-keyval start 0)(init-keyval end)(init-keyval count)
  1415.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1416.     (pwhen from-end (ret (reverse (remove item (reverse list) test key start end count))))
  1417.     (ret (remove item list test key start end count))))
  1418.  
  1419. (defun #>SYS::remove-duplicates (list &rest lkeys)
  1420.  (trace-progn 'SYS::remove-duplicates (list '&rest lkeys) ())
  1421.  (clet (test from-end test-not start end count key)
  1422.     (init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
  1423.     (funless key (csetq key #'identity))
  1424.     (funless test (csetq test #'eql))
  1425.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1426.     (funless start (csetq start 0))
  1427.     (pwhen from-end (ret (reverse (remove-duplicates (reverse list) test key start end))))
  1428.     (ret (remove-duplicates list test key start end))))
  1429.  
  1430. (defun #>SYS::delete-duplicates (list &rest lkeys)  
  1431.  (trace-progn 'SYS::delete-duplicates (list '&rest lkeys)
  1432.  (clet (test from-end test-not start end count key)
  1433.     (init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
  1434.     (funless key (csetq key #'identity))
  1435.     (funless test (csetq test #'eql))
  1436.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1437.     (funless start (csetq start 0))
  1438.     (pwhen from-end (ret (reverse (delete-duplicates (reverse list) test key start end))))
  1439.     (ret (delete-duplicates list test key start end)))))
  1440.  
  1441. (defun #>SYS::subsetp (list list2 &rest lkeys)
  1442.  (trace-progn 'SYS::subsetp (list list2 '&rest lkeys)
  1443.  (clet (test key test-not)
  1444.     (init-keyval test)(init-keyval key)(init-keyval test-not)  
  1445.     (funless key (csetq key #'identity))
  1446.     (funless test (csetq test #'eql))
  1447.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1448.     (ret (subsetp list list2 test key)))))
  1449.  
  1450. #||#
  1451.  
  1452. ;;(USE-PACKAGE :SYS :CYC #'better-symbol)
  1453.  
  1454.  
  1455.  
  1456.  
  1457.  
  1458.  
  1459. ;;(shadow-macro SYS::apply (fn &rest body) (ret `(apply ,fn ,@body)))
  1460. #|
  1461. ;;(export '(SYS::load like-funcall 'eval ))
  1462. #+CRISPY
  1463. '(defun #>SYS::eval (code)
  1464.     (force-print `(sl::eval ,code))
  1465.     (ret (SL::eval `(trace-progn ,code))))
  1466.  
  1467. ;;(defmacro  #>SYS::handler-case (form &rest cases) (print (list 'handler-case form cases)) (ret `,form))
  1468.  
  1469. (csetq  *load-verbose* t)
  1470. (csetq *load-print* t)
  1471.  
  1472. #+CRISPY
  1473. (defun #>SYS::load (filespec &rest lkeys)
  1474.  (KeyLet (verbose print if-does-not-exist external-format)
  1475.   (SL::clet ((*standard-input* (SL::OPEN-TEXT filespec :input)))
  1476.     (cdo () ()
  1477.     (clet ((expr (SL::read *standard-input* nil :EOF)))
  1478.      (pwhen (equal expr :EOF)
  1479.         (SL::close *standard-input*)
  1480.         (ret T))
  1481.       (SYS::eval expr))))))
  1482.  
  1483. |#
  1484.  
  1485.  
  1486.  
  1487.  
  1488. (defmacro  #>SYS::defstub (feat symb &optional default) `(define ,symb (&rest body) (format t "~s~%" (cons ',feat (cons ',symb body))) ,default))
  1489.  
  1490. #|
  1491.  
  1492. (defmacro  #>SYS::go (label)
  1493.  (let ((name (label-to-functionname label)))
  1494.   `(throw ,name #',name)))
  1495.  
  1496. (defmacro  #>SYS::tagbody (&body body)
  1497.     "The emulation of tagbody/go by catch/throw is considerably less obvious than the emulation of block/return-from.
  1498.    This is because tagbody defines a number of different labels rather than a single block name, and because the parsing of the
  1499.    tagbody body is considerably more complicated. The various segments of the tagbody are emulated by a labels nest of mutually
  1500.    recursive functions, which are forced to all execute at the correct dynamic depth by means of a
  1501.    'trampoline. If the implementation implements the 'tail recursion' optimization for functions
  1502.    which have no arguments and return no values, and if the simpler cases of go's are optimized away, then this emulation can be quite efficient."
  1503.              (let* ((init-tag (gensym)) (go-tag (gensym)) (return-tag (gensym))
  1504.                    
  1505.                     (functions
  1506.                      (mapcon
  1507.                          #'(lambda (seq &aux (label (car seq) (s (cdr seq)))
  1508.                                         (when (atom label)
  1509.                                           (let ((p (position-if #'atom s)))
  1510.                                             `((,(label-to-functionname label) ()
  1511.                                                  ,@(subseq s 0 (or p (length s)))
  1512.                                                  ,(if p `(,(label-to-functionname (elt s p)))
  1513.                                                     `(throw ,return-tag 'nil)))))))
  1514.                              `(,init-tag ,@body))))
  1515.                     `(let* ((,go-tag (list nil)) (,return-tag (list nil))
  1516.                                                  ,@(mapcar #'(lambda (f) `(,(car f) ,go-tag)) functions))
  1517.                        (catch ,return-tag
  1518.                               (labels ,functions
  1519.                                 (let ((nxt-label #',(caar functions)))
  1520.                                   (loop (csetq nxt-label (catch ,go-tag (funcall nxt-label)))))))))))
  1521.  
  1522.  
  1523. (defmacro  #>SYS::labels (fns &body forms)
  1524.              "CIRCULAR ENVIRONMENTS OF 'LABELS EMULATED BY 'FLET AND 'SETQ: It is generally believed that the circular environments of labels cannot be
  1525.    obtained by means of flet. This is incorrect, as the following emulation (reminiscent of Scheme) shows.
  1526.    With a more sophisticated macro-expansion, this emulation can be optimized into production-quality code."
  1527.              (let* ((fnames (mapcar #'car fns))
  1528.                     (nfnames (mapcar #'(lambda (ignore) (gensym)) fnames))
  1529.                     (nfbodies (mapcar #'(lambda (f) `#'(lambda ,@(cdr f))) fns)))
  1530.                `(let ,(mapcar #'(lambda (nf) `(,nf #'(lambda () ()))) nfnames)
  1531.                   (flet ,(mapcar #'(lambda (f nf) `(,f (&rest a) (apply ,nf a)))
  1532.                            fnames nfnames)
  1533.                     (flet ,fns
  1534.                       (sl::progn ,@(mapcar #'(lambda (f nf) `(csetq ,nf #',f))
  1535.                                  fnames nfnames))
  1536.                       ,@forms)))))
  1537.  
  1538. |#
  1539. ;;(defmacro  #>SYS::loop (&rest body) (ret `(loop ,@body)))
  1540.  
  1541.  
  1542. #|
  1543. ;; barely started coding
  1544. (defun #>SYS::array-dimensions (array subdim)
  1545.   (ret (pcase
  1546.     subdim
  1547.     (0 (length array)
  1548.     (t (length (nth subdim array)))))))
  1549.  
  1550. ;;;; CLtL2 and ANSI CL Compatibility
  1551.  
  1552. (defmacro  #>SYS::loop (&rest exps)
  1553.  ;;"supports both ansi and simple loop. warning:: not every loop keyword is supported."
  1554.  (format t "~%~s~%" `(SL::loop ,@exps))(force-output)
  1555.  (punless (member-if #'symbolp exps) (ret `(loop ,@exps)))
  1556.  (pcase (car exps)
  1557.    ((until while) (ret exps))
  1558.    (for ;;(SYS::loop-for (cdr exps)))
  1559.     (break "SYS::loop-for"))
  1560.    (repeat (break "SYS::loop-repeat"))
  1561.    (otherwise (ret `(SL::loop ,@exps))))
  1562.  
  1563. '(defmacro  #>SYS::loop-for (var from-in start/list &rest exps)
  1564.   (pcase
  1565.     from-in
  1566.     (from (SYS::loop-for-from var start/list
  1567.  ))))
  1568.  
  1569.  
  1570. ;; some tests
  1571. '(print (translate-block '
  1572.  (defun #>SYS::member (item list &key (test #'eql)(key #'identity) test-not)
  1573.    (pwhen test-not (setq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))  
  1574.    (member item list test key))))
  1575. |#
  1576.  
  1577. #| XXXXXXXXXXXXXXXXXXXXXxx
  1578. (defmacro  #>SYS::_setf (place value)
  1579.     (csetq value (sl::eval `(trace-progn value)))
  1580.     (with-error-handler
  1581.       #'(lambda () (ret value))
  1582.       (ret (csetf place value)))
  1583.    (pwhen (consp place)
  1584.      (clet ((object (cadr place))(type (type-of object))(slot (car place))(args (cddr place))(slotname (string slot)))
  1585.             (csetq slotname (get-type-slot-args type slot args))
  1586.             (csetq value (sl::eval `(,slotname ,object ,@(append args (list value)))))))
  1587.    (ret place))
  1588.  
  1589.  
  1590. (defmacro  #>SYS::_getf (place value)
  1591.   (csetq value (sl::eval `(trace-progn value)))
  1592.   (with-error-handler
  1593.       #'(lambda () (ret place))
  1594.       (ret (aref place value)))
  1595.     (pwhen (consp place)
  1596.      (clet ((object (cadr place))(type (type-of object))(slot (car place))(args (cddr place))(slotname (string slot)))
  1597.             (csetq slotname (get-type-slot-args type slot args  '("PUT" "GET-" "GET" "REF-" "REF")))
  1598.             (csetq value (sl::eval `(,slotname ,object ,@args)))))
  1599.   (ret place))
  1600.        
  1601.  (define get-type-slot-args (type slot args &optional trylist)
  1602.     (clet ((slotname (string slot))(typename (string slot)))
  1603.       (ret (member-if  #'(lambda (header)
  1604.                 (clet ((name (cconcatenate header slotname))(namef (find-symbol name))
  1605.                        tname (cconcatenate header slotname (typename type) ))(tnamef (find-symbol tname)))
  1606.                        (pwhen (fboundp tnamef) (ret tnamef))
  1607.                        (pwhen (fboundp namef) (ret namef))))
  1608.                        (append try '("_CSETF-" "SET-" "PUT-" "SET" )))))
  1609.    |#
  1610.    ;;; XXXXXXXXXXXXXXXXXXXXXxx
  1611.  
  1612. #|
  1613. Function MAP-INTO (still writing also require the array stuff way below)
  1614.  
  1615. Syntax::
  1616.  
  1617. map-into result-sequence function &rest sequences => result-sequence
  1618.  
  1619. Arguments and Values::
  1620.  
  1621. result-sequence--a proper sequence.
  1622. function--a designator for a function of as many arguments as there are sequences.
  1623. sequence--a proper sequence.
  1624.  
  1625. Description::
  1626.  
  1627. Destructively modifies result-sequence to contain the results of applying function to each element in the argument sequences in turn.
  1628.  
  1629. Examples::
  1630.  
  1631.  (setq a (list 1 2 3 4) b (list 10 10 10 10)) => (10 10 10 10)
  1632.  (map-into a #'+ a b) => (11 12 13 14)
  1633.  a => (11 12 13 14)
  1634.  b => (10 10 10 10)
  1635.  (setq k '(one two three)) => (ONE TWO THREE)
  1636.  (map-into a #'cons k a) => ((ONE . 11) (TWO . 12) (THREE . 13) 14)
  1637.  (map-into a #'gensym) => (#::G9090 #::G9091 #::G9092 #::G9093)
  1638.  a => (#::G9090 #::G9091 #::G9092 #::G9093)
  1639.  
  1640. (defun #>SYS::map-into (result-sequence function &rest sequences)
  1641.  "Destructively set elements of RESULT-SEQUENCE to the results
  1642. of applying FUNCTION to respective elements of SEQUENCES."
  1643.  (clet ((arglist (make-list (length sequences)))
  1644.      (n (fif (listp result-sequence)
  1645.         most-positive-fixnum
  1646.         (array-dimension result-sequence 0))))
  1647.   ;; arglist is made into a list of pattern for each call
  1648.   ;; n is the length of the longest vector
  1649.   (pwhen sequences
  1650.    (csetf n (min n (SYS::loop for seq in sequencesminimize (length seq)))))
  1651.   ;; shadow-defun :SYS some shared functions::
  1652.   (clet
  1653.    ((*do-one-call*
  1654.     #'(lambda (i)
  1655.      (ret (cdolist (seq sequences)
  1656.         (cdolist (arg arglist)
  1657.         (cdo (fif (listp (first seq))
  1658.            (csetf (first arg)
  1659.               (pop (first seq)))
  1660.            (csetf (first arg)
  1661.               (aref (first seq) i))))))))
  1662.      (apply function arglist))
  1663.     (*do-result*
  1664.      #'(lambda (i)
  1665.      (ret (fif (cand (vectorp result-sequence)
  1666.          (array-has-fill-pointer-p result-sequence))
  1667.        (csetf (fill-pointer result-sequence)
  1668.           (max i (fill-pointer result-sequence))))))))
  1669.    ;; (declare (inline *do-one-call*))
  1670.    ;; Decide if the result is a list or vector,
  1671.    ;; and SYS::loop through each element
  1672.    (fif (listp result-sequence)
  1673.      (SYS::loop for i from 0 to (- n 1)
  1674.         for r on result-sequence
  1675.         do (csetf (first r)
  1676.              (*do-one-call* i))
  1677.         finally (*do-result* i))
  1678.      (SYS::loop for i from 0 to (- n 1)
  1679.         do (csetf (aref result-sequence i)
  1680.              (*do-one-call* i))
  1681.         finally (*do-result* i))))
  1682.    result-sequence))
  1683. |##|
  1684.  
  1685. (defvar *complement-fns* (sl::make-hash-table 31) "defcomplement Hashtable to lookup how things like (complement #'member) might return")
  1686. (defun #>SYS::complement (fn)
  1687.  "If FN returns y, then (paip-complement FN) returns (not y)."
  1688.  (ret (pcond
  1689.    ((gethash fn *complement-fns*))
  1690.    (t #'(lambda (&rest pattern) (ret (cnot (apply fn pattern))))))))
  1691.  
  1692. ;; example:: (defcomplement < >=)
  1693. (defmacro  #>SYS::defcomplement (posfn negfn)
  1694.   (ret `(sl::progn (sethash #',posfn *complement-fns* #',negfn) (sethash #',negfn *complement-fns* #',posfn))))
  1695.  
  1696.  
  1697. ;; emits
  1698. ;;;;;;;;;;;;;;;;;  
  1699. (defun #>SYS::MEMBER (ITEM LIST &REST LKEYS)
  1700.  (RET
  1701.   (trace-progn  
  1702.   (CLET (TEST KEY TEST-NOT)
  1703.     (init-keyval KEY (FUNCTION IDENTITY)) (init-keyval TEST (FUNCTION EQL))
  1704.     (pWHEN TEST-NOT (SETQ TEST (FUNCTION (LAMBDA (X Y) (RET (CNOT (FUNCALL TEST-NOT X Y)))))))
  1705.     (MEMBER ITEM LIST TEST KEY)))))
  1706.  
  1707.  
  1708. '(print (translate-block '
  1709.  (defun #>SYS::intersection (list-1 list-2 &key (test #'eql)(key #'identity) test-not)
  1710.    (pwhen test-not (setq test #'(lambda (x y)(not (funcall test-not x y)))))
  1711.    (intersection list-1 list-2 test key))))
  1712.  
  1713. (defun #>SYS::intersection (list-1 list-2 &rest lkeys)
  1714.  (trace-progn 'SYS::intersection (list-1 list-2 '&rest lkeys)
  1715.  (clet (test key test-not)
  1716.     (init-keyval test)(init-keyval key)(init-keyval test-not)  
  1717.     (funless key (csetq key #'identity))
  1718.     (funless test (csetq test #'eql))
  1719.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1720.     (ret (intersection list-1 list-2 test key )))))
  1721.  
  1722.  
  1723. (defun #>SYS::remove (item list &rest lkeys )
  1724.  ;;(force-print `(SYS::remove ,item ,list &rest ,lkeys))
  1725.  (clet (test from-end test-not start end count key)
  1726.     (init-keyval test #'eql)(init-keyval key #'identity)(init-keyval test-not)(init-keyval from-end)(init-keyval start 0)(init-keyval end)(init-keyval count)
  1727.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1728.     (pwhen from-end (ret (reverse (remove item (reverse list) test key start end count))))
  1729.     (ret (remove item list test key start end count))))
  1730.  
  1731. (defun #>SYS::remove-duplicates (list &rest lkeys)
  1732.  (trace-progn 'SYS::remove-duplicates (list '&rest lkeys) ())
  1733.  (clet (test from-end test-not start end count key)
  1734.     (init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
  1735.     (funless key (csetq key #'identity))
  1736.     (funless test (csetq test #'eql))
  1737.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1738.     (funless start (csetq start 0))
  1739.     (pwhen from-end (ret (reverse (remove-duplicates (reverse list) test key start end))))
  1740.     (ret (remove-duplicates list test key start end))))
  1741.  
  1742. (defun #>SYS::delete-duplicates (list &rest lkeys)  
  1743.  (trace-progn 'SYS::delete-duplicates (list '&rest lkeys)
  1744.  (clet (test from-end test-not start end count key)
  1745.     (init-keyval test)(init-keyval key)(init-keyval test-not)(init-keyval from-end)(init-keyval start)(init-keyval end)(init-keyval count)
  1746.     (funless key (csetq key #'identity))
  1747.     (funless test (csetq test #'eql))
  1748.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1749.     (funless start (csetq start 0))
  1750.     (pwhen from-end (ret (reverse (delete-duplicates (reverse list) test key start end))))
  1751.     (ret (delete-duplicates list test key start end)))))
  1752.  
  1753. (defun #>SYS::subsetp (list list2 &rest lkeys)
  1754.  (trace-progn 'SYS::subsetp (list list2 '&rest lkeys)
  1755.  (clet (test key test-not)
  1756.     (init-keyval test)(init-keyval key)(init-keyval test-not)  
  1757.     (funless key (csetq key #'identity))
  1758.     (funless test (csetq test #'eql))
  1759.     (pwhen test-not (csetq test #'(lambda (x y)(ret (cnot (funcall test-not x y))))))
  1760.     (ret (subsetp list list2 test key)))))
  1761. |#
  1762.  
  1763. ;;(USE-PACKAGE :SYS :CYC #'better-symbol)
  1764.  
  1765. (reshare-symbols)      
  1766. (cpushnew :CYC-COMMON-LISP sl::*features*)
  1767.  
  1768.  
  1769. (punless (null (find-symbol "DEFINE" :SYS)) (unintern (find-symbol "DEFINE") :SYS))
  1770. (punless (null (find-symbol "DEFINE" :CL)) (unintern (find-symbol "DEFINE") :CL))
  1771. (import 'SL::DEFINE :SYS)
  1772. (export 'SL::DEFINE :SYS)
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!