Some features for CLOS implementation

repl-web/repl.lisp

@@ -14,9 +14,11 @@
 (/debug "loading repl-web/repl.lisp!")
 
 (defun %write-string (string &optional (escape t))
-  (if #j:jqconsole
-      (#j:jqconsole:Write string "jqconsole-output" "" escape)
-      (#j:console:log string)))
+    (if #j:jqconsole
+        (if escape
+            (#j:jqconsole:Write string "jqconsole-output")
+            (#j:jqconsole:Write string "jqconsole-output" ""))
+        (#j:console:log string)))
 
 (defun load-history ()
   (let ((raw (#j:localStorage:getItem "jqhist")))

src/boot.lisp

@@ -408,6 +408,13 @@
        ,@form)))
 
 
+;;; mop predicate
+(defun mop-object-p (obj)
+    (and (consp obj)
+         (eq (oget obj "tagName") :mop-object)
+         (= (length obj) 5)   ;; 3
+         (eq (car obj) 'std-instance)) )
+
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))
@@ -419,6 +426,9 @@
                          `((,(ecase (car c)
                                     (fixnum 'integerp)
                                     (integer 'integerp)
+                                    (structure 'structure-p)       
+                                    (hash-table 'hash-table-p)     
+                                    (mop-object 'mop-object-p) 
                                     (cons 'consp)
                                     (list 'listp)
                                     (vector 'vectorp)
@@ -492,3 +502,28 @@
      t)
     (t
      nil)))
+
+
+;;; print-unreadable-object
+(defmacro !print-unreadable-object ((object stream &key type identity) &body body)
+  (let ((g!stream (gensym))
+        (g!object (gensym)))
+    `(let ((,g!stream ,stream)
+           (,g!object ,object))
+       (simple-format ,g!stream "#<")
+       ,(when type
+          (error "type-of yet not implemented")
+          `(simple-format ,g!stream "~S" (type-of g!object)))
+       ,(when (and type (or body identity))
+          `(simple-format ,g!stream " "))
+       ,@body
+       ,(when (and identity body)
+          `(simple-format ,g!stream " "))
+       (simple-format ,g!stream ">")
+       nil)))
+
+
+#+jscl
+(defmacro print-unreadable-object ((object stream &key type identity) &body body) 
+    `(!print-unreadable-object (,object ,stream :type ,type :identity ,identity) ,@body))
+

src/defstruct.lisp

@@ -15,6 +15,12 @@
 
 (/debug "loading defstruct.lisp!")
 
+;;; object 'structure'  predicate
+(defun structure-p (obj)
+  (and (consp obj)
+       (symbolp (car obj))
+       (eq (oget obj "tagName") :structure)))
+
 ;; A very simple defstruct built on lists. It supports just slot with
 ;; an optional default initform, and it will create a constructor,
 ;; predicate and accessors for you.
@@ -53,20 +59,26 @@
            copier-expansion)
 
 
+      ;; mark object as :structure 
       (when constructor
         (setq constructor-expansion
               `(defun ,constructor (&key ,@slot-descriptions)
-                 (list ',name ,@(mapcar #'car slot-descriptions)))))
+                 (let ((obj (list ',name ,@(mapcar #'car slot-descriptions)))) 
+                   #+jscl (oset :structure obj "tagName")
+                   obj))))
 
       (when predicate
         (setq predicate-expansion
               `(defun ,predicate (x)
                  (and (consp x) (eq (car x) ',name)))))
 
+      ;; mark copy as :structure
       (when copier
         (setq copier-expansion
               `(defun ,copier (x)
-                 (copy-list x))))
+                 (let ((obj (copy-list x)))
+                   #+jscl (oset :structure obj "tagName")
+                   obj))))
 
       `(progn
          ,constructor-expansion

src/hash-table.lisp

@@ -38,7 +38,7 @@
      x)
     (t
      (unless (in "$$jscl_id" x)
-       (oset (format nil "$~d" *eq-hash-counter*) x "$$jscl_id")
+       (oset (concat "$" *eq-hash-counter*) x "$$jscl_id")
        (incf *eq-hash-counter*))
      (oget x "$$jscl_id"))))
 
@@ -63,18 +63,25 @@
   ;; by now.
   )
 
+;;; hash-table predicate
+(defun hash-table-p (obj)
+  (and (consp obj)
+       (eq (oget obj "tagName") :hash-table)
+       (= (length obj) 3)
+       (eq (car obj) 'hash-table)))
+
 
 (defun make-hash-table (&key (test #'eql) size)
-  (let* ((test-fn (fdefinition test))
-         (hash-fn
-          (cond
-            ((eq test-fn #'eq)    #'eq-hash)
-            ((eq test-fn #'eql)   #'eql-hash)
-            ((eq test-fn #'equal) #'equal-hash)
-            ((eq test-fn #'equalp) #'equalp-hash))))
-    ;; TODO: Replace list with a storage-vector and tag
-    ;; conveniently to implemnet `hash-table-p'.
-    `(hash-table ,hash-fn ,(new))))
+    (let* ((test-fn (fdefinition test))
+           (hash-fn
+             (cond
+               ((eq test-fn #'eq)    #'eq-hash)
+               ((eq test-fn #'eql)   #'eql-hash)
+               ((eq test-fn #'equal) #'equal-hash)
+               ((eq test-fn #'equalp) #'equalp-hash)))
+           (obj `(hash-table ,hash-fn ,(new))))
+        (oset :hash-table obj "tagName") 
+        obj))
 
 (defun gethash (key hash-table &optional default)
   (let* ((obj (caddr hash-table))

src/prelude.js

@@ -77,6 +77,11 @@ internals.newInstance = function(values, ct){
   return new newCt();
 };
 
+// Workaround the problem with send NULL for async XHR 
+var reqXHRsendNull = function(req){
+  req.send(null);
+};
+
 
 // NOTE: Define VALUES to be MV for toplevel forms. It is because
 // `eval' compiles the forms and execute the Javascript code at

src/print.lisp

@@ -146,6 +146,9 @@
                       nil))))
                (visit (x)
                  (cond
+                   ;; prevent scan infinity mop pbjects
+                   ((mop-object-p x) 
+                    (mark x))
                    ((and x (symbolp x) (null (symbol-package x)))
                     (mark x))
                    ((consp x)
@@ -251,6 +254,12 @@
        (if name
            (simple-format stream "#<FUNCTION ~a>" name)
            (write-string "#<FUNCTION>" stream))))
+    ;; mop object
+    (mop-object (mop-object-printer form stream))
+    ;; structure object
+    (structure (structure-object-printer form stream))
+    ;; hash-table object
+    (hash-table (hash-table-object-printer form stream))
     ;; Lists
     (list
      (write-char #\( stream)
@@ -297,12 +306,39 @@
     (t x)))
 
 #+jscl
-(defun write (form &key (stream *standard-output*))
+(defun invoke-object-printer (fn form &optional (stream *standard-output*))
   (let ((stream (output-stream-designator stream)))
-    (multiple-value-bind (objs ids)
-        (scan-multiple-referenced-objects form)
-      (write-aux form stream objs ids)
-      form)))
+    (funcall fn form stream)))
+
+;;; structure object printer
+(defun structure-object-printer (form stream)
+  (let ((res))
+    (setq res (concat "#<structure " (string-downcase (string (car form))) ">"))
+    (simple-format stream res)))
+
+;;; hash-table printer
+(defun hash-table-object-printer (form stream)
+  (let* ((hashfn (cadr form))
+         (fname (oget hashfn "fname"))
+         (tail-pos (position #\- fname))
+         (testfn (subseq fname 0 tail-pos))
+         (res))
+    (setq res (concat "#<hash-table :test " (string-downcase testfn) ">"))
+    (simple-format stream res)))
+
+#+jscl
+(defun write (form &key (stream *standard-output*))
+  (cond ((mop-object-p form)
+         (invoke-object-printer #'mop-object-printer form stream))
+        ((hash-table-p form)
+         (invoke-object-printer #'hash-table-object-printer form stream))
+        ((structure-p form)
+         (invoke-object-printer #'structure-object-printer form stream))
+        (t  (let ((stream (output-stream-designator stream)))
+              (multiple-value-bind (objs ids)
+                  (scan-multiple-referenced-objects form)
+                (write-aux form stream objs ids)
+                form)))))
 
 #+jscl
 (defun write-to-string (form)

src/toplevel.lisp

@@ -168,6 +168,7 @@
    maphash mapl maplist mask-field max member member-if member-if-not
    merge merge-pathnames method method-combination
    method-combination-error method-qualifiers min minusp mismatch mod
+   mop-object mop-object-p
    most-negative-double-float most-negative-fixnum
    most-negative-long-float most-negative-short-float
    most-negative-single-float most-positive-double-float
@@ -321,3 +322,73 @@
 
 (when (jscl::web-worker-p)
   (jscl::initialize-web-worker))
+
+;;;
+;;; LOAD - load file
+;;;
+(defun _xhr_receiver_ (uri fn-ok &optional fn-err)
+  (let ((req (make-new #j:XMLHttpRequest)))
+    ((oget req "open" ) "GET" uri t)
+    ((oget req "setRequestHeader") "Cache-Control" "no-cache")
+    ((oget req "setRequestHeader") "Cache-Control" "no-store")
+    (setf (oget req "onreadystatechange")
+          (lambda (evt)
+            (if (= (oget req "readyState") 4)
+                (if (= (oget req "status") 200)
+                    (funcall fn-ok (oget req "responseText"))
+                    (if fn-err
+                        (funcall fn-err uri (oget req "status") )
+                        (format t "xhr: ~a~%    ~a~%" (oget req "statusText") uri )) ))))
+    (funcall (%js-vref "reqXHRsendNull") req) ))
+
+
+(defun _ldr_eval_ (sexpr verbose)
+  (if verbose
+      (format t "~a ~a~%" (car sexpr) (cadr sexpr)))
+  (%js-try
+   (handler-case
+       (progn
+         (dolist (x (multiple-value-list (eval sexpr)))
+           (format t  "~a~%"  x))
+         t)
+     (error (msg)
+       (format t "Error: ~a~%" (!condition-args msg))
+       nil))
+   (catch (err)
+     (format t "Error: ~a~%" (or (oget err "message") err))
+     nil)))
+
+
+(defun _load_form_eval_ (input verbose)
+  (let ((stream)
+        (expr)
+        (eof (gensym "LOADER" )))
+    (setq stream (make-string-input-stream input))
+    (terpri)
+    (tagbody
+     rdr-feeder
+       (setq expr (ls-read stream nil eof))
+       (if (eql expr eof)
+           (go rdr-eof))
+       (_ldr_eval_ expr verbose)
+       (go rdr-feeder)
+     rdr-eof)
+    (values)))
+
+
+
+;;; replace cntrl-r from input
+(defun _ldr_ctrl-r_replace_ (src)
+  (let ((reg (#j:RegExp (code-char 13) "g")))
+    ((oget (lisp-to-js src) "replace") reg " ")))
+
+
+;;; (load "./app.lisp" :verbose t)
+(defun load (name &key verbose)
+  (_xhr_receiver_ name
+                  (lambda (input)
+                    (_load_form_eval_ (_ldr_ctrl-r_replace_ input) verbose))
+                  (lambda (url status)
+                    (format t "~%Load: Can't load ~a~%     Status ~%" url status)))
+  (terpri)
+  (values))

tests/ffi.lisp

@@ -7,3 +7,34 @@
 (test (stringp (#j:Date 0)))
 (test (< 32 (length (#j:Date 0))))
 
+;;; Array
+(let ((v1 #(mediane)))
+  ((jscl::oget v1 "push") 'right)
+  ((jscl::oget v1 "unshift") 'left)
+  (test (equal ((jscl::oget v1 "indexOf") 'mediane) 1))
+  (test (equal ((jscl::oget v1 "indexOf") 'left) 0))
+  (test (equal ((jscl::oget v1 "indexOf") 'right) 2))
+  (test (equal (map 'list #'identity v1) '(left mediane right))))
+
+(let ((v2 (jscl::make-new #j:Array 'left "Mediane" 'right)))
+  (test (equal (jscl::vector-to-list v2) '(left "Mediane" right))))
+
+;;; String
+(test (string= ((oget (jscl::lisp-to-js "abcdef") "substr") 1 2) "bc"))
+
+;;; Number's format output
+;;; for future features
+(let ()
+  (labels
+      ((make-number (value) 
+         (jscl::make-new #j:Number value))
+       (float-Exponential (value &optional (fraction 5))
+         ((jscl::oget (make-Number value) "toExponential") fraction))
+       (number-to-fixed (value &optional (digits 0))
+         ((jscl::oget  (make-Number value) "toFixed") digits))
+       (number-by-radix (value &optional (radix 10))
+         ((jscl::oget (make-Number value) "toString") radix)))
+    (test (string= "1.23e+2" (float-exponential 123.1 2)))
+    (test (string= "123.01" (number-to-fixed 123.012345 2)))
+    (test (string= "a" (number-by-radix 10 16))) 
+    (test (string= "1100100" (number-by-radix 100 2)))))

tests/print.lisp

@@ -51,3 +51,13 @@
                    (write-to-string list)))))
 
 
+;;; lisp structured objects pretty printed
+(progn
+  (defstruct struct name slots)
+  (test (string= "#<structure struct>"  (write-to-string (make-struct))))
+  (test (string= "#<structure struct>"  (write-to-string (make-struct :name 'definition :slots #(a b c))))))
+
+(let ((ht (make-hash-table :test #'equal)))
+  (test (string= "#<hash-table :test equal>"  (write-to-string ht)))
+  (map nil (lambda (k v) (setf (gethash k ht) v)) '(a b c "aaa") '(1 2 3 c))
+  (test (string= "#<hash-table :test equal>"  (write-to-string ht))))