Merge branch 'development'

NEWS

@@ -1,3 +1,7 @@
+Changes of tre-0.7 relative to tre-0.6:
+  * (%NEW): Accidentally converted to (%NEW NIL) – fixed.
+  * PHP: Debugged property and associative array functions.
+
 Changes of tre-0.6 relative to tre-0.5:
   * PHP: PROPERTY-NAMES fixed for associative arrays.
   * PHP: ASSOC-ARRAY? test if first key is a string.

environment/platforms/php/request-path.lisp

@@ -1,8 +1,8 @@
-(defvar *request-path-offset* nil)
-(defvar *base-url* nil)
+(var *request-path-offset* nil)
+(var *base-url* nil)
 
 (fn parse-request-path ()
-  (with (path  (%%%href *_SERVER* "SCRIPT_NAME")
+  (with (path  (%aref *_SERVER* "SCRIPT_NAME")
          comp  (path-pathlist path)
          ofs   (? comp
                   (-- (length comp))

environment/transpiler/environment/make-object.lisp

@@ -1,6 +1,6 @@
 (fn make-object (&rest x)
   (!= (%%%make-object)
     (@ (i (group x 2) !)
-      (%%%=-aref .i. ! (? (symbol? i.)
-                          (downcase (symbol-name i.))
-                          i.)))))
+      (=-%aref .i. ! (? (symbol? i.)
+                        (downcase (symbol-name i.))
+                        i.)))))

environment/transpiler/environment/property.lisp

@@ -1,17 +1,17 @@
 (fn properties-alist (x)
-  (@ [. _ (aref x _)] (property-names x)))
+  (@ [. _ (%aref x _)] (property-names x)))
 
 (fn alist-properties (x)
   (& x
      (aprog1 (new)
-       (@ [= (aref ! _.) ._] x))))
+       (@ [=-%aref ._ ! _.] x))))
 
 (fn merge-properties (a b)
   (aprog1 (new)
     (@ (i (property-names a))
-      (= (aref ! i) (aref a i)))
+      (=-%aref (%aref a i) ! i))
     (@ (i (property-names b))
-      (= (aref ! i) (aref b i)))))
+      (=-%aref (%aref b i) ! i))))
 
 (fn copy-properties (x)
   (merge-properties x nil))

environment/transpiler/front-end/expression-expand.lisp

@@ -70,7 +70,7 @@
          eargs  (? (defined-function fun)
                    (compiled-arguments fun (expex-argdef fun) args)
                    args))
-    `(,@(& new? '(%new)) ,fun ,@(expand-literal-characters eargs))))
+    `(,@(& new? '(%new)) ,@(!? fun (list !)) ,@(expand-literal-characters eargs))))
 
 
 ;;;;; MOVING ARGUMENTS

environment/transpiler/targets/javascript/class.lisp

@@ -8,14 +8,13 @@
      bases))
 
 (fn js-gen-constructor (class-name bases args body)
-  (let magic (list 'quote ($ '__ class-name))
-    `{(fn ,class-name ,args
-        (%thisify ,class-name
-          (macrolet ((super (&rest args)
-                       `((slot-value ,bases. 'call) this ,,@args)))
-            ,@body)))
-	  (fn ,($ class-name '?) (x)
-	    (%%native x " instanceof " ,(compiled-function-name-string class-name)))}))
+  `{(fn ,class-name ,args
+      (%thisify ,class-name
+        (macrolet ((super (&rest args)
+                     `((slot-value ,bases. 'call) this ,,@args)))
+          ,@body)))
+    (fn ,($ class-name '?) (x)
+      (%%native x " instanceof " ,(compiled-function-name-string class-name)))})
 
 (define-js-std-macro defclass (class-name args &body body)
   (apply #'generic-defclass #'js-gen-constructor class-name args body))
@@ -27,25 +26,24 @@
   (apply #'generic-defmember class-name names))
 
 (fn js-emit-method (class-name x)
-  (alet ($ '~meth- class-name '- x.)
+  (!= ($ '~meth- class-name '- x.)
     (. `((%%native ,x.) #',!)
 	   `(fn ,! ,.x.
 		  (%thisify ,class-name
 	        ,@(| ..x. (list nil)))))))
 
 (fn js-emit-methods (class-name cls)
-  (awhen (@ [js-emit-method class-name _]
-            (reverse (class-methods cls)))
-	`(,@(cdrlist !)
-      ,@(js-gen-inherit-methods class-name (!? (class-parent cls)
-                                               (class-name !)))
-      (hash-merge (slot-value ,class-name 'prototype)
-	              (%%%make-object ,@(apply #'+ (carlist !)))))))
+  (!? (@ [js-emit-method class-name _]
+         (reverse (class-methods cls)))
+	  `(,@(cdrlist !)
+        ,@(js-gen-inherit-methods class-name (!? (class-parent cls)
+                                                 (class-name !)))
+        (hash-merge (slot-value ,class-name 'prototype)
+	                (%%%make-object ,@(apply #'+ (carlist !)))))))
 
 (define-js-std-macro finalize-class (class-name)
   (print-definition `(finalize-class ,class-name))
-  (let classes (thisify-classes)
-    (!? (href classes class-name)
-	    `{,(assoc-value class-name *delayed-constructors*)
-		  ,@(js-emit-methods class-name !)}
-	    (error "Cannot finalize undefined class ~A." class-name))))
+  (!? (href (thisify-classes) class-name)
+      `{,(assoc-value class-name *delayed-constructors*)
+        ,@(js-emit-methods class-name !)}
+      (error "Cannot finalize undefined class ~A." class-name)))

environment/transpiler/targets/javascript/codegen.lisp

@@ -145,17 +145,17 @@
 (define-js-macro make-array (&rest elements)
   `(%%native ,@(c-list elements :brackets :square)))
 
-(define-js-macro %%%aref (arr &rest idx)
+(define-js-macro %aref (arr &rest idx)
   `(%%native ,arr ,@(@ [`("[" ,_ "]")] idx)))
 
-(define-js-macro %%%=-aref (val &rest x)
-  `(%%native (%%%aref ,@x) " = " ,val))
+(define-js-macro =-%aref (val &rest x)
+  `(%%native (%aref ,@x) " = " ,val))
 
 (define-js-macro aref (arr &rest idx)
-  `(%%%aref ,arr ,@idx))
+  `(%aref ,arr ,@idx))
 
 (define-js-macro =-aref (val &rest x)
-  `(%%%=-aref ,val ,@x))
+  `(=-%aref ,val ,@x))
 
 
 ;;;; HASH TABLES

environment/transpiler/targets/javascript/core/array.lisp

@@ -1,8 +1,8 @@
-(fn aref (a k)            (%%%aref a k))
-(fn =-aref (v a k)        (%%%=-aref v a k))
+(fn aref (a k)            (%aref a k))
+(fn =-aref (v a k)        (=-%aref v a k))
 (fn array? (x)            (*array.is-array x))
-(defmacro aref (a k)      `(%%%aref ,a ,k))
-(defmacro =-aref (v a k)  `(%%%=-aref ,v ,a ,k))
+(defmacro aref (a k)      `(%aref ,a ,k))
+(defmacro =-aref (v a k)  `(=-%aref ,v ,a ,k))
 (defmacro array? (x)      `(*array.is-array ,x))
 
 (fn list-array (x)

environment/transpiler/targets/javascript/core/hash.lisp

@@ -16,10 +16,10 @@
 
 (fn %%objkey ()
   (setq *obj-id-counter* (%%%+ 1 *obj-id-counter*))
-  (%%%string+ "~~O" *obj-id-counter*))
+  (+ "~~O" *obj-id-counter*))
 
 (fn %%numkey (x)
-  (%%%string+ "~~N" x))
+  (+ "~~N" x))
 
 (fn hashkeys (hash)
   (? (& (hash-table? hash)
@@ -30,17 +30,17 @@
 (fn %make-href-object-key (hash key)
   (unless (defined? key.__tre-object-id)
     (= key.__tre-object-id (%%objkey)))
-  (%%%=-aref key hash.__tre-keys key.__tre-object-id)
+  (=-%aref key hash.__tre-keys key.__tre-object-id)
   key.__tre-object-id)
 
 (fn %href-key (hash key)
   (? (object? key)
      (%make-href-object-key hash key)
      (aprog1 (%%numkey key)
-       (%%%=-aref key hash.__tre-keys !))))
+       (=-%aref key hash.__tre-keys !))))
 
 (fn =-href-obj (value hash key)
-  (%%%=-aref value hash (%href-key hash key)))
+  (=-%aref value hash (%href-key hash key)))
 
 (fn %href-==? (x)
   (| (eq x #'==)
@@ -50,24 +50,24 @@
 (fn =-href (value hash key)
   (!? (%htest hash)
       (? (%href-==? !)
-         (%%%=-aref value hash key)
+         (=-%aref value hash key)
          (=-href-obj value hash key))
-      (%%%=-aref value hash key)))
+      (=-%aref value hash key)))
 
 (fn %href-user (hash key)
   (@ (k (hashkeys hash))
     (& (funcall hash.__tre-test k key)
-       (return (%%%aref hash (%href-key hash k))))))
+       (return (%aref hash (%href-key hash k))))))
 
 (fn href (hash key)
   (!? (%htest hash)
       (?
-        (eq #'eq !)   (%%%aref hash (? (object? key)
-                                       key.__tre-object-id
-                                       (%%numkey key)))
-        (%href-==? !) (%%%aref hash key)
+        (eq #'eq !)   (%aref hash (? (object? key)
+                                     key.__tre-object-id
+                                     (%%numkey key)))
+        (%href-==? !) (%aref hash key)
         (%href-user hash key))
-      (%%%aref hash key)))
+      (%aref hash key)))
 
 (fn hash-merge (a b)
   (when (| a b)
@@ -77,7 +77,7 @@
     (%= nil (%%native
                 "for (var k in " b ") "
                     "if (k != \"" '__tre-object-id "\" && k != \"" '__tre-test "\" && k != \"" '__tre-keys "\") "
-                        a "[k] = " b "[k];"))
+                        a "[k] = " b "[k]"))
     a))
 
 (fn copy-hash-table (x)

environment/transpiler/targets/javascript/core/property-list.lisp

@@ -1,4 +1,4 @@
-(defvar *%property-list-tmp* nil)
+(var *%property-list-tmp* nil)
 
 (defnative %property-list-0 (key val)
   (acons! key val *%property-list-tmp*))
@@ -8,5 +8,5 @@
   (%= nil (%%native
               "for (var k in " hash ") "
                   "if (k != \"" ,(obfuscated-identifier '__tre-object-id) "\" && k != \"" ,(obfuscated-identifier '__tre-test) "\" && k != \"" ,(obfuscated-identifier '__tre-keys) "\") "
-                      ,(compiled-function-name-string '%property-list-0) " (typeof k == \"string\" && typeof " hash "." ,(obfuscated-identifier '__tre-keys) " != \"undefined\" ? (" hash "." ,(obfuscated-identifier '__tre-keys) "[k] || k) : k, " hash "[k]);"))
+                      ,(compiled-function-name-string '%property-list-0) " (typeof k == \"string\" && typeof " hash "." ,(obfuscated-identifier '__tre-keys) " != \"undefined\" ? (" hash "." ,(obfuscated-identifier '__tre-keys) "[k] || k) : k, " hash "[k])"))
   (reverse *%property-list-tmp*))

environment/transpiler/targets/javascript/core/symbol.lisp

@@ -17,10 +17,10 @@
                                (!? *package*
                                    !.n
                                    "NIL"))
-              symbol-table  (| (%%%aref *symbols* pkg-name)
-   				               (%%%=-aref (%%%make-object) *symbols* pkg-name)))
-         (| (%%%aref symbol-table name)
-            (%%%=-aref (new %symbol name pkg) symbol-table name))))))
+              symbol-table  (| (%aref *symbols* pkg-name)
+   				               (=-%aref (%%%make-object) *symbols* pkg-name)))
+         (| (%aref symbol-table name)
+            (=-%aref (new %symbol name pkg) symbol-table name))))))
 
 (setq *package* (symbol "TRE" nil))
 

environment/transpiler/targets/php/codegen.lisp

@@ -52,11 +52,11 @@
 
 (define-php-macro %%go-nil (tag val)
   (let v (php-dollarize val)
-    (php-line "if (!" v " && !is_string (" v ") && !is_numeric (" v ") && !is_array (" v ")) { " (php-jump tag) "; }")))
+    (php-line "if (!" v " && !is_string (" v ") && !is_numeric (" v ") && !is_array (" v ")) " (php-jump tag))))
 
 (define-php-macro %%go-not-nil (tag val)
   (let v (php-dollarize val)
-    (php-line "if (!(!" v " && !is_string (" v ") && !is_numeric (" v ") && !is_array (" v "))) { " (php-jump tag) "; }")))
+    (php-line "if (!(!" v " && !is_string (" v ") && !is_numeric (" v ") && !is_array (" v "))) " (php-jump tag))))
 
 
 ;;;; FUNCTIONS
@@ -227,32 +227,20 @@
 (define-php-macro =-aref (val arr &rest indexes)
   `(=-href ,val ,arr ,@indexes))
 
-(define-php-macro php-aref (arr &rest indexes)
+(define-php-macro %aref (arr &rest indexes)
   `(%%native ,(php-dollarize arr) ,@(php-array-subscript indexes)))
 
-(define-php-macro %%%=-aref (val &rest x)
-  `(=-php-aref ,val ,@x))
-
-(define-php-macro php-aref-defined? (arr &rest indexes)
+(define-php-macro %aref-defined? (arr &rest indexes)
   `(%%native "isset (" ,(php-dollarize arr) ,@(php-array-subscript indexes) ")"))
 
-(define-php-macro =-php-aref (val &rest x)
-  `(%%native (php-aref ,@x)
+(define-php-macro =-%aref (val &rest x)
+  `(%%native (%aref ,@x)
              ,(php-assignment-operator val)
              ,(php-dollarize val)))
 
 
 ;;;; HASH TABLES
 
-(fn php-array-indexes (x)
-  (mapcan [list "[" (php-dollarize _) "]"] x))
-
-(define-php-macro %%%href (h &rest k)
-  `(%%native ,(php-dollarize h) ,@(php-array-indexes k)))
-
-(define-php-macro %%%href-set (v h &rest k)
-  `(%%native ,(php-dollarize h) ,@(php-array-indexes k) " = " ,(php-dollarize v)))
-
 (define-php-macro href (h k)
   `(%%native "(is_a (" ,(php-dollarize h) ", '__l') || is_a (" ,(php-dollarize h) ", '__array')) ? "
                  ,(php-dollarize h) "->g(tre_T37T37key (" ,(php-dollarize k) ")) : "
@@ -280,7 +268,7 @@
 (define-php-macro %new (&rest x)
   (? x
      `(%%native "new " ,x. ,@(php-argument-list .x))
-     `(%%native "new stdClass()")))
+     `(%%native "[]")))
 
 (define-php-macro delete-object (x)
   `(%%native "null; unset " ,x))

environment/transpiler/targets/php/core/array.lisp

@@ -25,10 +25,10 @@
 
 (fn aref (a k)
   (? (is_array a)
-     (php-aref a k)
+     (%aref a k)
      (href a k)))
 
 (fn (= aref) (v a k)
   (? (is_array a)
-     (=-php-aref v a k)
+     (=-%aref v a k)
      (=-href v a k)))

environment/transpiler/targets/php/core/hash.lisp

@@ -21,8 +21,8 @@
                               (? (%%%== p "_kw")
                                  *keyword-package*
                                  (make-symbol p)))))
-         "L" (%%%href *conses* (substr x 3))
-         "A" (%%%href *arrays* (substr x 3))
+         "L" (%aref *conses* (substr x 3))
+         "A" (%aref *arrays* (substr x 3))
          "C" (code-char (substr x 3))
          (error "Illegal index ~A." x)))
      x))
@@ -32,34 +32,21 @@
      (@ #'%%unkey (x.keys))
      (maparray #'identity (phphash-hashkeys x))))
 
-(fn hash-merge (a b)
+(fn hash-merge (a b)    ; TODO: Use generic version.
   (| a (= a (make-hash-table)))
   (@ (k (hashkeys b) a)
     (= (href a k) (href b k))))
 
-(fn alist-phphash (x)
-  (!= (%%%make-object)
-    (@ (i x !)
-      (%%%href-set .i ! i.))))
-
-(fn phphash-alist (x)
-  (with-queue q
-    (@ (i (hashkeys x) (queue-list q))
-      (enqueue q (. i (aref x i))))))
-
-(fn %href-error (h)
-  (error "HREF expects an hash table instead of ~A." h))
-
 (fn href (h k)
   (alet (%%key k)
     (? (is_a h "__array")
        (h.g !)
-       (& (php-aref-defined? h !)
-          (php-aref h !)))))
+       (& (%aref-defined? h !)
+          (%aref h !)))))
 
 (fn (= href) (v h k)
   (alet (%%key k)
     (?  (is_a h "__array")
         (h.s (%%key !) v)
-        (=-php-aref v h !) v))
+        (=-%aref v h !) v))
   v)