Merge pull request #446 from vlad-km/cls-reord

Some features and pathes

Author: davazp

src/boot.lisp

@@ -585,4 +585,15 @@
 (defmacro print-unreadable-object ((object stream &key type identity) &body body) 
     `(!print-unreadable-object (,object ,stream :type ,type :identity ,identity) ,@body))
 
+
+(defmacro %%assert (test &optional ignore datum &rest args)
+  (let ((value (gensym "ASSERT-VALUE")))
+       `(let ((,value ,test))
+         (when (not ,value)
+           (jscl::%%assert-error ',test ,datum ,@args)))))
+#+jscl
+(defmacro assert (test &optional ignore datum &rest args)
+  `(%%assert ,test ,ignore ,datum ,@args))
+
+
 ;;; EOF

src/clos/std-object.lisp

@@ -376,6 +376,7 @@
               ;; accessor writer fn
               ;; make (setf name) symbolic name
               (push-on-end `(setf ,(cadr olist)) writers))
+             (:documentation)
              (otherwise
               (push-on-end `',(car olist) other-options)
               (push-on-end `',(cadr olist) other-options))))
@@ -398,6 +399,7 @@
 (eval-always
  (defun canonicalize-defclass-option (option)
    (case (car option)
+     (:documentation)
      (:metaclass (list ':metaclass `(!find-class ',(cadr option))))
      (:default-initargs
       (list ':direct-default-initargs
@@ -492,6 +494,7 @@
 
 ;;; N.B. Quietly retain all unknown slot options (rather than signaling an
 ;;; error), so that it's easy to add new ones.
+;;; BUG: this lambda form is not working - &allow-other-keys parsed incorrectly 
 (defun make-direct-slot-definition
     (&rest properties
      &key name (initargs ()) (initform nil) (initfunction nil) (readers ()) (writers ()) (allocation :instance)
@@ -506,6 +509,7 @@
     (setf (getf* slot ':allocation) allocation)
     slot))
 
+;;; BUG: this lambda form is not working - &allow-other-keys parsed incorrectly
 (defun make-effective-slot-definition
     (&rest properties
      &key name (initargs ()) (initform nil) (initfunction nil) (allocation :instance)

src/conditions.lisp

@@ -127,9 +127,9 @@
     (check-type condition warning)
     (%%signal condition)
     (format stream "WARNING: ")
-    (format stream (simple-condition-format-control condition)
-            (simple-condition-format-arguments condition))
-    (write-char #\newline)
+    (apply 'format stream (simple-condition-format-control condition)
+           (simple-condition-format-arguments condition))
+    (write-char #\newline stream)
     nil))
 
 (defun %%error (datum &rest args)
@@ -231,16 +231,7 @@
 				                 :format-control "Assert failed: ~s."
 				                 :format-arguments (list form)))))
 
-(defmacro %%assert (test &optional ignore datum &rest args)
-  (let ((value (gensym "ASSERT-VALUE"))
-        (name (gensym "ASSERT-BLOCK")))
-    `(block
-         ,name
-       (let ((,value ,test))
-         (when (not ,value)
-           (%%assert-error ',test ,datum ,@args))))))
-
-
+;;; @vlad-km macro %%assert moved to boot.lisp
 
 #+jscl
 (progn
@@ -257,9 +248,6 @@
   (defmacro ignore-errors (&rest forms)
     `(%%ignore-errors ,@forms))
 
-  (defmacro assert (test &optional ignore datum &rest args)
-    `(%%assert ,test ,ignore ,datum ,@args))
-
   (fset 'make-condition #'%%make-condition)
   (fset 'signal #'%%signal)
   (fset 'warn #'%%warn)

src/load.lisp

@@ -1,6 +1,5 @@
 ;;; -*- mode:lisp;  coding:utf-8 -*-
 
-
 ;;;
 ;;; LOAD - load & compile Common Lisp file.
 ;;;        Simple implementation of the common Lisp function 'load'
@@ -48,7 +47,13 @@
           (format t  "  ~a~%"  x))
         t)
     (error (msg)
-      (format t "Error: ~a~%" (!condition-args msg))
+      (typecase condition
+        (simple-error
+         (apply #'format t
+                (simple-condition-format-control condition)
+                (simple-condition-format-arguments condition)))
+        (t  (let* ((*print-escape* nil))
+              (print-object condition))))
       nil))
   nil)
 
@@ -112,12 +117,14 @@
 ;;;
 ;;; hook  - #() store place for js-code
 ;;;
-;;;          (setq bin #())
+;;;          IMPORTANT!! don't use literal #() (see Issue #345)
+;;;          (setq bin (make-array 0 :fillpointer 0)) 
 ;;;          (load "file1.lisp" :hook bin)
 ;;;          (load "file2.lisp" :hook bin)
 ;;;          (load "file3.lisp" :hook bin :output "lib.js")
 ;;;              => will be bundle js-code file1, file2, file3 from bin to "lib.js"
 ;;;
+;;;         
 ;;;         you will be use (require "./lib") or use html tag:
 ;;;         <script src="lib.js" type="text/javascript" charset="utf-8"></script>
 ;;;         without compilation.
@@ -129,6 +136,21 @@
 (defun node-environment-p ()
   (if (find :node *features*) t))
 
+;;;
+;;; how to bypass cors restrictions
+;;; 1. on the command line issue the command:
+;;;               chrome.exe --user-data-dir="????????" --disable-web-security
+;;; will launch chrome in disbale-websecurity mode. (By path "????????" will be you Chrome account) 
+;;; 2. enter devtool/source
+;;; 3. click add workspace
+;;; 4. add your folder with  jscl.js, jscl-web.js, jscl.html
+;;; 5. allow devtool to work with the filesystem
+;;;   all files from your directory will be loaded
+;;; 6. select the file JSCL.HTML and open it in a new tab
+;;;    now, you can load:
+;;;          source lisp files with the LOAD function
+;;;          js files - with function JS-LOAD
+;;;          css files - with function CSS-LOAD
 
 (defun load (name &key verbose (sync (node-environment-p)) output place hook)
   (terpri)
@@ -142,12 +164,12 @@
          (loader-sync-mode name verbose output place hook)
          (loader-async-mode name verbose output place hook)))
     ;; browser platform
-    (t
-     (when sync
-       (warn "sync mode only for node/electron platform~%will be used async mode"))
-     (when (or output hook)
-       (warn "output/hook options only for node/electron platform"))
-     (loader-browser-mode name verbose)))
+    (t (when sync
+         (warn "sync mode only for node/electron platform~%will be used async mode"))
+       (when (or output hook)
+         (warn "output/hook options only for node/electron platform"))
+       (warn "In browser mode, the LOAD function is executed ONLY if `web-security` is DISABLED (CORS restriction)")
+       (loader-browser-mode name verbose)))
   (values))
 
 
@@ -157,17 +179,17 @@
    (lambda (input)
      (_load_form_eval_ (_ldr_ctrl-r_replace_ input) verbose))
    (lambda (url status)
-     (format t "~%Load: Can't load ~a~%     Status ~%" url status))))
+     (format t "~%Load: Can't load ~a~%       Status: ~a~%" url status))))
 
 ;;; alowe make bundle from source received from local fs (by FILE:)
-;;; or from remote resource (by HTTP:)
+;;; or from remote resourse (by HTTP:)
 (defun loader-async-mode (name verbose bundle-name place hook)
   (_xhr_receiver_
    name
    (lambda (input)
      (_load_eval_bundle_ (_ldr_ctrl-r_replace_ input) verbose bundle-name place hook))
    (lambda (url status)
-     (format t "~%Load: Can't load ~a~%     Status ~%" url status))))
+     (format t "~%Load: Can't load ~a~%       Status: ~a~%" url status))))
 
 ;;; sync mode
 (defun loader-sync-mode (name verbose bundle-name place hook)
@@ -188,7 +210,8 @@
     (when bundle-name
       (if hook
           (setq code-stor hook)
-          (setq code-stor #()))
+          ;; see Issue #345, #350, #397
+          (setq code-stor (make-array 0 :fill-pointer 0)))
       (setq fbundle t))
     (setq stream (make-string-input-stream input))
     (tagbody sync-loader-rdr
@@ -202,13 +225,14 @@
                (setq code (compile-toplevel expr t t))
                (setq rc (js-eval code))
                (when verbose (format t "  ~a~%" rc))
-               ;; so, expr already verified
+               ;; so, expr already verifyed
                ;; store expression after compilation/evaluated
                (cond (fbundle ((oget code-stor "push") code))
                      (hook ((oget code-stor "push") code))
                      (t t)) ))
          (error (msg)
-           (format t "Error: ~a~%" (!condition-args msg))
+           (format t "   Error: ")
+           (load_cond_err_handl_ msg)
            ;; break read-eval loop
            ;; no bundle
            (setq fbundle nil)
@@ -222,6 +246,24 @@
       (setq code-stor nil))
     (values)))
 
+;;; error message handle path
+(defun _load_cond_err_handl_(condition)
+  (typecase condition
+    (simple-error
+     (apply #'format t
+            (simple-condition-format-control condition)
+            (simple-condition-format-arguments condition)))
+    (type-error
+     ;; note:
+     ;; there can be custom event handling here.
+     ;; while it remains as it was done.
+     ;; sometime later
+     (let* ((*print-escape* nil))
+       (print-object condition)))
+    (t  (let* ((*print-escape* nil))
+          (print-object condition))))
+  (write-char  #\newline))
+
 
 ;;; Check what output directory exists
 (defun _loader_check_output_directory_ (path)

src/misc.lisp

@@ -68,6 +68,25 @@
 (defvar *traced-functions* nil)
 (defvar *trace-level* 0)
 
+;;; @vlad-km 04-09-2022
+;;; Prevent RangeError: Maximum call stack size exceeded
+;;; on  trace call
+(defvar *prevent-trace-stop-list*
+  '(trace
+    princ prin1 prin1-to-string princ-to-string 
+    print
+    format !format
+    write write-char write-string write-integer write-symbol write-line write-to-string
+    terpri fresh-line))
+
+(defun %prevent-infinite-trace (name)
+  (typecase name
+    (symbol
+     (if (jscl::memq name *prevent-trace-stop-list*)
+         (error "Trace - `~S` this function is not traceable." name)))
+    (otherwise (error "Trace - the traceable function name `~S` must be a symbol." name))))
+
+
 (defun trace-report-call (name args)
   (dotimes (i *trace-level*) (write-string " "))
   (format t "~a: ~S~%" *trace-level* (cons name args)))
@@ -82,13 +101,14 @@
   (if (null names)
       (mapcar #'car *traced-functions*)
       (dolist (name names names)
+        (%prevent-infinite-trace name)
         (if (find name *traced-functions* :key #'car)
             (format t "`~S' is already traced.~%" name)
             (let ((func (fdefinition name)))
               (fset name (lambda (&rest args)
                            (let (values)
                              (trace-report-call name args)
-                             (let ((*trace-level* (+ *trace-level* 1)))
+                             (let ((*trace-level* (1+ *trace-level*)))
                                (setq values (multiple-value-list (apply func args))))
                              (trace-report-return name values)
                              (values-list values))))