Issue 384 - TYPES and CONDITION (#390)

* Update std-object.lisp Removed `builtin-in-class-of` function. Now the function location - src/types.lisp * Update types.lisp added %check-type-error * Update types.lisp added `deftype-compound` macro with aux functions for numerical types such as (INTEGER * *) ... (NUMBER * *) * Update types.lisp added numeric types: INTEGER - NUMBER * Update types.lisp added types VECTOR, ARRAY * Update types.lisp added type (CONS * *) with familiary functions * Update types.lisp added non canonical type LIST * Update types.lisp added DEFTYPE macro definition * Update types.lisp removed commentary * Update types.lisp Predefinition types MOD, FIXNUM, BIGNUN, SIGNED-BYTE, UNSIGNED-BYTE * Update types.lisp code clear * Update types.lisp added suplimentary functions for SIGNED/UNSIGNED * Update types.lisp added type BIT for unsigned byte 0/1 * Update types.lisp fix compound type ARRAY for dimensions and canonical type specification (ARRAY TYPE DIMENSIONS) * fix !typep * Update types.lisp * Fix NUMBERS predicates added %integer-p as Number.isInteger method added REALP, RATIONALP predicates * Update symbol.lisp added (defun symbolp ) * Update char.lisp fix CHARACTERP * Update boot.lisp added some functions for TYPES object-type-code set-object-type-code used to read and write a TYPE-TAGs ex: (set-object-type-code cell :structure) * Fix TYPES predicate * Added CHECK-TYPE macro tiny * Update boot.lisp added TYPECASE ETYPECASE macro * Update boot.lisp * Update builtin-in-class * Create types.lisp Added typep/ type-of test cases * Update boot.lisp fix `mop-object` * tests apply revision * tests apply revision * tests characters revision * tests clos revision * tests conditionals revision * tests control revision * tests defun revision * tests equal revision * tests eval revision * tests ffi revision * tests format revision * tests hash-tables revision * tests iter-macros revision * tests list revision * tests misc revision * tests numbers revision * tests package revision * tests print revision * tests multiple-values revision * tests read revision * tests seq revision * tests setf revision * tests stream revision * tests strings revision * tests types revision * tests variables revision * tests loop base-tests revision * tests loop extended-tests revision * tests loop validate revision * fix integerp arg * fix clos hierarhy restore stream, structure classes * Update defstruct.lisp fix structure-p with object-type-code * Update std-object.lisp fix std-object-p with object-type-code * fix types * Update boot.lisp * Update describe.lisp * Update numbers.lisp * Update types.lisp * fix typep -> !typep fix push -> %push-end * fix object-type-code * fix rational type * fix boot.lisp typep-expander fixed added kludge %coerce-panic-arg * Update types.lisp fix built-in-class-of * added type-of * Update types.lisp fixed deftype's * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update numbers.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * fixed * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update types.lisp * Update conditions.lisp * Update conditions.lisp * Create conditions.lisp * Update test facilities * Update conditions.lisp * Update conditions.lisp * Update conditions.lisp * Update conditions.lisp add new handler-bind with OR syntax * Update conditions.lisp * Update conditions.lisp * Update conditions.lisp * Update conditions.lisp * Update conditions.lisp RIP * Update conditions.lisp * Update repl.lisp Replace toplevel fn * Update conditions.lisp * Update repl.lisp * Update repl.lisp fixed parentheses balance * Update format.lisp fixed format error condition arguments * Update types.lisp fixed * Fixed STRING type * add cons test * Added cons test * Update types.lisp * Update types.lisp * Update conditions.lisp added IGNORE-ERRORS form * Update conditions.lisp fix parentheses balance * Update types.lisp * fixed * Update ffi.lisp * Fixed arguments for format both (expected-type condition) and (format-arguments condition) return list * Update boot.lisp 1) move js-null, js-undefined to FFI, move true/false/void to TYPES, redefine CHECK-TYPE macro * Moved js-null-p, js-undefined-p from BOOT * Moved true,false,void from BOOT * Redesign BOOT ordering `types family` section * Fixed code style conditions.lisp rename macro `define-condition) -> %define-condition added macro define-condition ::= `(%define-condition ...) under #+jscl * Update conditions.lisp added check-type * Fixed coerce-condition * update tests/conditions.lisp clean up test unit * Replace REPL toplevel with defgeneric condition handler * Moved true-list, true-cons predicates to TYPES
jscl-project · Mar 27, 2021 · d38eec2 · d38eec2
1 parent ac08402
commit d38eec2
Show file tree

Hide file tree

Showing 45 changed files with 1,874 additions and 297 deletions.
diff --git a/src/boot.lisp b/src/boot.lisp
@@ -1,3 +1,5 @@
+;;; -*- mode:lisp; coding:utf-8 -*-
+
 ;;; boot.lisp --- First forms to be cross compiled
 
 ;; Copyright (C) 2012, 2013 David Vazquez
@@ -409,78 +411,6 @@
     `(multiple-value-call (lambda ,gvars ,@setqs)
        ,@form)))
 
-
-;;; mop predicate
-(defun mop-object-p (obj)
-    (and (consp obj)
-         (eq (oget obj "tagName") :mop-object)
-         (= (length obj) 5)))
-
-;;; js-object predicate
-(defun js-object-p (obj)
-  (if (or (sequencep obj)
-          (numberp obj)
-          (symbolp obj)
-          (functionp obj)
-          (packagep obj))
-      nil
-      t))
-
-;; Incorrect typecase, but used in NCONC.
-(defmacro typecase (x &rest clausules)
-  (let ((value (gensym)))
-    `(let ((,value ,x))
-       (cond
-         ,@(mapcar (lambda (c)
-                     (if (find (car c) '(t otherwise))
-                         `(t ,@(rest c))
-                         `((,(ecase (car c)
-                                    (fixnum 'integerp)
-                                    (integer 'integerp)
-                                    (structure 'structure-p)       
-                                    (hash-table 'hash-table-p)     
-                                    (mop-object 'mop-object-p) 
-                                    (js-object  'js-object-p)
-                                    (cons 'consp)
-                                    (list 'listp)
-                                    (vector 'vectorp)
-                                    (character 'characterp)
-                                    (sequence 'sequencep)
-                                    (symbol 'symbolp)
-                                    (keyword 'keywordp)
-                                    (function 'functionp)
-                                    (float 'floatp)
-                                    (array 'arrayp)
-                                    (string 'stringp)
-                                    (atom 'atom)
-                                    (null 'null)
-                                    (package 'packagep))
-                             ,value)
-                           ,@(or (rest c)
-                                 (list nil)))))
-                   clausules)))))
-
-(defmacro etypecase (x &rest clausules)
-  (let ((g!x (gensym)))
-    `(let ((,g!x ,x))
-       (typecase ,g!x
-         ,@clausules
-         (t (error "~S fell through etypecase expression." ,g!x))))))
-
-
-;;; No type system is implemented yet.
-(defun subtypep (type1 type2)
-  (cond
-    ((null type1)
-     (values t t))
-    ((eq type1 type2)
-     (values t t))
-    ((eq type2 'number)
-     (values (and (member type1 '(fixnum integer)) t)
-             t))
-    (t
-     (values nil nil))))
-
 (defun notany (fn seq)
   (not (some fn seq)))
 
@@ -512,11 +442,120 @@
 
 (defparameter *features* '(:jscl :common-lisp))
 
+;;; symbol-function from compiler macro
+(defun functionp (f) (functionp f))
+
+;;; types family section
+
+;;; tag's utils
+(defun object-type-code (object) (oget object "dt_Name"))
+(defun set-object-type-code (object tag) (oset tag object "dt_Name"))
+
+;;; types predicate's
+(defun mop-object-p (obj)
+    (and (consp obj)
+         (eql (object-type-code obj) :mop-object)
+         (= (length obj) 5)))
+
+(defun clos-object-p (object) (eql (object-type-code object) :clos_object))
+
+;;; macro's
+(defun %check-type-error (place value typespec string)
+   (error "Check type error.~%The value of ~s is ~s, is not ~a ~a."
+          place value typespec (if (null string) "" string)))
+
+(defmacro %check-type (place typespec &optional (string ""))
+  (let ((value (gensym)))
+    (if (symbolp place)
+        `(do ((,value ,place ,place))
+             ((!typep ,value ',typespec))
+           (setf ,place (%check-type-error ',place ,value ',typespec ,string)))
+        (if (!typep place typespec)
+            t
+            (%check-type-error place place typespec string)))))
+
+#+jscl
+(defmacro check-type (place typespec &optional (string ""))
+  `(%check-type ,place ,typespec ,string))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro %push-end (thing place) `(setq ,place (append ,place (list ,thing))))
+
+  (defparameter *basic-type-predicates*
+    '((hash-table . hash-table-p) (package . packagep) (stream . streamp)
+      (atom . atom) (structure . structure-p) (js-object . js-object-p)
+      ;; todo: subtypep - remove mop-object from tables
+      (clos-object . mop-object-p) (mop-object . mop-object-p) (character . characterp)
+      (symbol . symbolp)  (keyword . keywordp)
+      (function . functionp) 
+      (number . numberp) (real . realp) (rational . rationalp) (float . floatp)
+      (integer . integerp)
+      (sequence .  sequencep) (list . listp) (cons . consp) (array . arrayp)
+      (vector . vectorp) (string . stringp) (null . null)))
+
+  (defun simple-base-predicate-p (expr)
+    (if (symbolp expr)
+        (let ((pair (assoc expr *basic-type-predicates*)))
+          (if pair (cdr pair) nil))))
+
+  (defun typecase-expander (object clausules)
+    (let ((key)
+          (body)
+          (std-p)
+          (g!x (gensym "TYPECASE"))
+          (result '()))
+      (dolist (it clausules (reverse result))
+        (setq key (car it)
+              body (cdr it)
+              std-p (simple-base-predicate-p key))
+        ;; (typecase keyform (type-spec form*))
+        ;; when: type-spec is symbol in *basic-type-predicates*, its predicate
+        ;;       -> (cond ((predicate keyform) form*))
+        ;; otherwise: (cond ((typep keyform (type-spec form*))))
+        (cond (std-p (%push-end `((,std-p ,g!x) ,@body) result))
+              ((or (eq key 't) (eq key 'otherwise))
+               (%push-end `(t ,@body) result))
+              (t (%push-end `((!typep ,g!x ',key) ,@body) result))))
+      `(let ((,g!x ,object))
+         (cond ,@result))))
+  )
+
+(defmacro typecase (form &rest clausules)
+  (typecase-expander `,form `,clausules))
+
+(defmacro etypecase (x &rest clausules)
+  `(typecase ,x
+     ,@clausules
+     (t (error "~S fell through etypecase expression." ,x))))
+
+
+;;; it remains so. not all at once. with these - live...
+(defun subtypep (type1 type2)
+  (cond
+    ((null type1)
+     (values t t))
+    ((eq type1 type2)
+     (values t t))
+    ((eq type2 'number)
+     (values (and (member type1 '(fixnum integer)) t)
+             t))
+    (t
+     (values nil nil))))
+
 ;;; Early error definition.
+(defun %coerce-panic-arg (arg)
+  (cond ((symbolp arg) (concat "symbol: " (symbol-name arg)))
+        ((consp arg ) (concat "cons: " (car arg)))
+        ((numberp arg) (concat "number:" arg))
+        (t " @ ")))
+
 (defun error (fmt &rest args)
   (if (fboundp 'format)
       (%throw (apply #'format nil fmt args))
-      (%throw (lisp-to-js (concat "BOOT PANIC! " (string fmt))))))
+    (%throw (lisp-to-js (concat "BOOT PANIC! "
+                                (string fmt)
+                                " "
+                                (%coerce-panic-arg (car args)))))))
 
 ;;; print-unreadable-object
 (defmacro !print-unreadable-object ((object stream &key type identity) &body body)
@@ -526,7 +565,6 @@
            (,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 " "))
@@ -541,3 +579,4 @@
 (defmacro print-unreadable-object ((object stream &key type identity) &body body) 
     `(!print-unreadable-object (,object ,stream :type ,type :identity ,identity) ,@body))
 
+;;; EOF
diff --git a/src/char.lisp b/src/char.lisp
@@ -1,5 +1,7 @@
 (/debug "loading char.lisp!")
 
+(defun characterp (ch) (characterp ch))
+
 ;; These comparison functions heavily borrowed from SBCL/CMUCL (public domain).
 
 (defun char= (character &rest more-characters)

diff --git a/src/clos/bootstrap.lisp b/src/clos/bootstrap.lisp
@@ -100,16 +100,18 @@
                 :direct-superclasses '()
                 :direct-slots   '())
 
-
   (ensure-class 'function
                 :direct-superclasses '()
                 :direct-slots   '())
 
-
   (ensure-class 'hash-table
                 :direct-superclasses '()
                 :direct-slots   '())
 
+  (ensure-class 'stream
+                :direct-superclasses '()
+                :direct-slots   '())
+
   (ensure-class 'structure
                 :direct-superclasses '()
                 :direct-slots   '())
@@ -118,8 +120,8 @@
                 :direct-superclasses '()
                 :direct-slots   '())
 
-  (ensure-class 'stream
-                :direct-superclasses '()
+  (ensure-class 'keyword
+                :direct-superclasses (LIST (!FIND-CLASS (QUOTE symbol)))
                 :direct-slots   '())
 
   (ensure-class 'list
@@ -142,12 +144,20 @@
                 :direct-superclasses (LIST (!FIND-CLASS (QUOTE vector)))
                 :direct-slots   '())
 
-  (ensure-class 'integer
+  (ensure-class 'real
                 :direct-superclasses (LIST (!FIND-CLASS (QUOTE number)))
                 :direct-slots   '())
 
+  (ensure-class 'rational
+                :direct-superclasses (LIST (!FIND-CLASS (QUOTE real)))
+                :direct-slots   '())
+
+  (ensure-class 'integer
+                :direct-superclasses (LIST (!FIND-CLASS (QUOTE rational)))
+                :direct-slots   '())
+
   (ensure-class 'float
-                :direct-superclasses (LIST (!FIND-CLASS (QUOTE number)))
+                :direct-superclasses (LIST (!FIND-CLASS (QUOTE real)))
                 :direct-slots   '())
 
   ;; 10. Define the other standard metaobject classes.

diff --git a/src/clos/describe.lisp b/src/clos/describe.lisp
@@ -331,25 +331,16 @@
 ;;; with dirty hack for recognize list or cons
 (defmethod describe ((obj list) &optional (stream *standard-output*))
   (with-pp-buffer (buf)
-    (cond ((its-cons-p obj)
+    (cond ((true-cons-p obj)
            (pp/presentation obj 'cons buf)
            (format buf "Car: ~s~%Cdr: ~s~%" (car obj) (cdr obj)))
           (t
-           (let ((len (length obj)))
+           (let ((len (list-length obj)))
              (pp/presentation obj 'list buf)
              (format buf "Length: ~a~%" len)
              (dotimes (idx len)
                (format buf  "~d: ~s~%" idx (nth idx obj))))))
     (flush-pp-buffer buf stream))
   (values))
 
-;;; dirty hack
-(defun its-cons-p (obj)
-  (handler-case
-      (progn
-        (length obj)
-        nil)
-    (error (msg)
-      t)))
-
 ;;; EOF
diff --git a/src/clos/std-object.lisp b/src/clos/std-object.lisp
@@ -58,7 +58,7 @@
                                          *secret-unbound-value*)
            :hash nil
            :cn nil )))
-    (setf (oget instance "tagName") :mop-object)
+    (set-object-type-code  instance :mop-object)
     instance ))
 
 
@@ -242,27 +242,6 @@
       (std-instance-class x)
       (built-in-class-of x)))
 
-(defun built-in-class-of (x)
-  (typecase x
-    (null                         (!find-class 'null))
-    (hash-table                   (!find-class 'hash-table))
-    (structure                    (!find-class 'structure))
-    (symbol                       (!find-class 'symbol))
-    (integer                      (!find-class 'integer))
-    (float                        (!find-class 'float))
-    (cons                         (!find-class 'cons))
-    (character                    (!find-class 'character))
-    (package                      (!find-class 'package))
-    (string                       (!find-class 'string))
-    (vector                       (!find-class 'vector))
-    (array                        (!find-class 'array))
-    (sequence                     (!find-class 'sequence))
-    (function                     (!find-class 'function))
-    (js-object                    (!find-class 'js-object))
-    (t                            (!find-class 't))))
-
-
-
 ;;; subclassp and sub-specializer-p
 (defun subclassp (c1 c2)
   (not (null (find c2 (class-precedence-list c1)))))

diff --git a/src/compiler/compiler.lisp b/src/compiler/compiler.lisp
@@ -1157,6 +1157,9 @@
 (define-builtin numberp (x)
   (convert-to-bool `(== (typeof ,x) "number")))
 
+(define-builtin %integer-p (x)
+  (convert-to-bool `(method-call |Number| "isInteger" ,x)))
+
 (define-builtin %truncate (x)
 `(method-call |Math| "trunc" ,x))