diff --git a/NEWS b/NEWS index d512f454..363184da 100644 --- a/NEWS +++ b/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. diff --git a/environment/platforms/php/request-path.lisp b/environment/platforms/php/request-path.lisp index e27485d8..8e4d37ba 100644 --- a/environment/platforms/php/request-path.lisp +++ b/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)) diff --git a/environment/transpiler/environment/make-object.lisp b/environment/transpiler/environment/make-object.lisp index d8d1969b..7182786d 100644 --- a/environment/transpiler/environment/make-object.lisp +++ b/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.))))) diff --git a/environment/transpiler/environment/property.lisp b/environment/transpiler/environment/property.lisp index 0ddf87be..63df6c0b 100644 --- a/environment/transpiler/environment/property.lisp +++ b/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)) diff --git a/environment/transpiler/front-end/expression-expand.lisp b/environment/transpiler/front-end/expression-expand.lisp index 6e4e9595..ec28f6a7 100644 --- a/environment/transpiler/front-end/expression-expand.lisp +++ b/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 diff --git a/environment/transpiler/targets/javascript/class.lisp b/environment/transpiler/targets/javascript/class.lisp index 50cd8836..c20aec20 100644 --- a/environment/transpiler/targets/javascript/class.lisp +++ b/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))) diff --git a/environment/transpiler/targets/javascript/codegen.lisp b/environment/transpiler/targets/javascript/codegen.lisp index bd6d7bc9..8cd84d73 100644 --- a/environment/transpiler/targets/javascript/codegen.lisp +++ b/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 diff --git a/environment/transpiler/targets/javascript/core/array.lisp b/environment/transpiler/targets/javascript/core/array.lisp index a0c545f7..5323c2ad 100644 --- a/environment/transpiler/targets/javascript/core/array.lisp +++ b/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) diff --git a/environment/transpiler/targets/javascript/core/hash.lisp b/environment/transpiler/targets/javascript/core/hash.lisp index 76bd00e0..7b888ead 100644 --- a/environment/transpiler/targets/javascript/core/hash.lisp +++ b/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) diff --git a/environment/transpiler/targets/javascript/core/property-list.lisp b/environment/transpiler/targets/javascript/core/property-list.lisp index b4de10bf..5f014b6e 100644 --- a/environment/transpiler/targets/javascript/core/property-list.lisp +++ b/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*)) diff --git a/environment/transpiler/targets/javascript/core/symbol.lisp b/environment/transpiler/targets/javascript/core/symbol.lisp index e5bda372..ab5c5b97 100644 --- a/environment/transpiler/targets/javascript/core/symbol.lisp +++ b/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)) diff --git a/environment/transpiler/targets/php/codegen.lisp b/environment/transpiler/targets/php/codegen.lisp index a2dc11b6..3e79e8e4 100644 --- a/environment/transpiler/targets/php/codegen.lisp +++ b/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)) diff --git a/environment/transpiler/targets/php/core/array.lisp b/environment/transpiler/targets/php/core/array.lisp index f8e5af79..5c88bb6a 100644 --- a/environment/transpiler/targets/php/core/array.lisp +++ b/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))) diff --git a/environment/transpiler/targets/php/core/hash.lisp b/environment/transpiler/targets/php/core/hash.lisp index 65cd9ade..0152f67d 100644 --- a/environment/transpiler/targets/php/core/hash.lisp +++ b/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)