Use def!struct

[jscl.git] / src / compiler.lisp

diff --git a/src/compiler.lisp b/src/compiler.lisp
index 53ec318..3dc2f1c 100644 (file)
--- a/src/compiler.lisp
+++ b/src/compiler.lisp
@@ -87,62 +87,6 @@
 ;;; function call.
 (defvar *multiple-value-p* nil)
 
-;; 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.
-(defmacro def!struct (name &rest slots)
-  (unless (symbolp name)
-    (error "It is not a full defstruct implementation."))
-  (let* ((name-string (symbol-name name))
-         (slot-descriptions
-          (mapcar (lambda (sd)
-                    (cond
-                      ((symbolp sd)
-                       (list sd))
-                      ((and (listp sd) (car sd) (cddr sd))
-                       sd)
-                      (t
-                       (error "Bad slot description `~S'." sd))))
-                  slots))
-         (predicate (intern (concat name-string "-P"))))
-    `(progn
-       ;; Constructor
-       (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
-         (list ',name ,@(mapcar #'car slot-descriptions)))
-       ;; Predicate
-       (defun ,predicate (x)
-         (and (consp x) (eq (car x) ',name)))
-       ;; Copier
-       (defun ,(intern (concat "COPY-" name-string)) (x)
-         (copy-list x))
-       ;; Slot accessors
-       ,@(with-collect
-          (let ((index 1))
-            (dolist (slot slot-descriptions)
-              (let* ((name (car slot))
-                     (accessor-name (intern (concat name-string "-" (string name)))))
-                (collect
-                    `(defun ,accessor-name (x)
-                       (unless (,predicate x)
-                         (error "The object `~S' is not of type `~S'" x ,name-string))
-                       (nth ,index x)))
-                ;; TODO: Implement this with a higher level
-                ;; abstraction like defsetf or (defun (setf ..))
-                (collect
-                    `(define-setf-expander ,accessor-name (x)
-                       (let ((object (gensym))
-                             (new-value (gensym)))
-                         (values (list object)
-                                 (list x)
-                                 (list new-value)
-                                 `(progn
-                                    (rplaca (nthcdr ,',index ,object) ,new-value) 
-                                    ,new-value)
-                                 `(,',accessor-name ,object)))))
-                (incf index)))))
-       ',name)))
-
-
 ;;; Environment
 
 (def!struct binding
@@ -574,13 +518,13 @@
   #+common-lisp
   (let ((package (symbol-package symbol)))
     (if (eq package (find-package "KEYWORD"))
-        (code "{name: " (dump-string (symbol-name symbol))
-              ", 'package': " (dump-string (package-name package)) "}")
-        (code "{name: " (dump-string (symbol-name symbol)) "}")))
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
+              (dump-string (package-name package)) "))")
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
   #+jscl
   (let ((package (symbol-package symbol)))
     (if (null package)
-        (code "{name: " (dump-symbol (symbol-name symbol)) "}")
+        (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")
         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 
 (defun dump-cons (cons)
@@ -1415,13 +1359,10 @@
     (code "(x.cdr = " new ", x)")))
 
 (define-builtin symbolp (x)
-  (js!bool
-   (js!selfcall
-     "var tmp = " x ";" *newline*
-     "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
+  (js!bool (code "(" x " instanceof Symbol)")))
 
 (define-builtin make-symbol (name)
-  (code "({name: " name "})"))
+  (code "(new Symbol(" name "))"))
 
 (define-builtin symbol-name (x)
   (code "(" x ").name"))
@@ -1478,6 +1419,12 @@
     "r.type = 'character';"
     "return r"))
 
+(define-builtin char-upcase (x)
+  (code x ".toUpperCase()"))
+
+(define-builtin char-downcase (x)
+  (code x ".toLowerCase()"))
+
 (define-builtin stringp (x)
   (js!bool
    (js!selfcall
@@ -1611,14 +1558,6 @@
 
 ;;; Javascript FFI
 
-;; Receives the JS function as first argument as a literal string. The
-;; second argument is compiled and should evaluate to a vector of
-;; values to apply to the the function. The result returned. No type
-;; conversion is done here. It is supposed to happen in the
-;; trampoline.
-(define-builtin %js-call (fun args)
-  (code fun ".apply(this, " args "))"))
-
 (define-compilation %js-vref (var)
   (code "js_to_lisp(" var ")"))