diff --git a/repl-web/repl.lisp b/repl-web/repl.lisp index 57d37691..d608225a 100644 --- a/repl-web/repl.lisp +++ b/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"))) diff --git a/src/boot.lisp b/src/boot.lisp index 5942b596..7acec23e 100644 --- a/src/boot.lisp +++ b/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)) + diff --git a/src/defstruct.lisp b/src/defstruct.lisp index 34c0da71..f9275e70 100644 --- a/src/defstruct.lisp +++ b/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 diff --git a/src/hash-table.lisp b/src/hash-table.lisp index c50b6a2e..b1981f6d 100644 --- a/src/hash-table.lisp +++ b/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)) diff --git a/src/prelude.js b/src/prelude.js index 9c71a9f3..17b1b18e 100644 --- a/src/prelude.js +++ b/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 diff --git a/src/print.lisp b/src/print.lisp index 67a171f8..68b95d62 100644 --- a/src/print.lisp +++ b/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 "#" name) (write-string "#" 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 "#")) + (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 "#")) + (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) diff --git a/src/toplevel.lisp b/src/toplevel.lisp index 8b9365b5..f9bf49a6 100644 --- a/src/toplevel.lisp +++ b/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)) diff --git a/tests/ffi.lisp b/tests/ffi.lisp index e6468497..c0f2cf63 100644 --- a/tests/ffi.lisp +++ b/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))))) diff --git a/tests/print.lisp b/tests/print.lisp index c159e568..00431ea1 100644 --- a/tests/print.lisp +++ b/tests/print.lisp @@ -51,3 +51,13 @@ (write-to-string list))))) +;;; lisp structured objects pretty printed +(progn + (defstruct struct name slots) + (test (string= "#" (write-to-string (make-struct)))) + (test (string= "#" (write-to-string (make-struct :name 'definition :slots #(a b c)))))) + +(let ((ht (make-hash-table :test #'equal))) + (test (string= "#" (write-to-string ht))) + (map nil (lambda (k v) (setf (gethash k ht) v)) '(a b c "aaa") '(1 2 3 c)) + (test (string= "#" (write-to-string ht))))