Verified Commit 59d82b98 authored by Vladimir Sedach's avatar Vladimir Sedach
Browse files

Added compatibility for :preserve readtable-case (Allegro modern)

parent 12afafde
......@@ -341,13 +341,15 @@ form, FORM, returns the new value for *compilation-level*."
(let ((compile-expression? t))
(ps-compile form)))
(defun ps-gensym (&optional (prefix-or-counter "_JS"))
(assert (or (stringp prefix-or-counter) (integerp prefix-or-counter)))
(let ((prefix (if (stringp prefix-or-counter) prefix-or-counter "_JS"))
(counter (if (integerp prefix-or-counter) prefix-or-counter (incf *ps-gensym-counter*))))
(make-symbol (format nil "~A~:[~;_~]~A" prefix
(digit-char-p (char prefix (1- (length prefix))))
(defun ps-gensym (&optional (x '_js))
(if (integerp x)
(format nil "~A~A" '_js x)
(let ((prefix (string x)))
(format nil "~A~:[~;_~]~A"
(digit-char-p (char prefix (1- (length prefix))))
(incf *ps-gensym-counter*))))))
(defmacro with-ps-gensyms (symbols &body body)
"Each element of SYMBOLS is either a symbol or a list of (symbol
......@@ -35,6 +35,7 @@
(in-package #:parenscript)
(named-readtables:in-readtable :parenscript)
(defvar *ps-html-empty-tag-aware-p* t)
(defvar *ps-html-mode* :sgml "One of :sgml or :xml")
......@@ -76,20 +77,20 @@
attr-val (pop attrs))
(if attr-test
(push `(if ,attr-test
(stringify ,(format nil " ~A=\"" attr-name) ,attr-val "\"")
(stringify ,(format nil " ~(~A~)=\"" attr-name) ,attr-val "\"")
(push (format nil " ~A=\"" attr-name) r)
(push (format nil " ~(~A~)=\"" attr-name) r)
(push attr-val r)
(push "\"" r)))))
(process-form% (tag attrs content)
(push (format nil "<~A" tag) r)
(push (format nil "<~(~A~)" tag) r)
(process-attrs attrs)
(if (or content (not (empty-tag-p tag)))
(progn (push ">" r)
(map nil #'process-form content)
(push (format nil "</~A>" tag) r))
(push (format nil "</~(~A~)>" tag) r))
(progn (when (eql *ps-html-mode* :xml)
(push "/" r))
(push ">" r))))
......@@ -110,12 +111,12 @@
(cond ((keywordp form) (process-form (list form)))
((atom form) (push form r))
((and (consp form) (keywordp (car form)))
(push (format nil "<~A" (car form)) r)
(push (format nil "<~(~A~)" (car form)) r)
(labels ((process-attributes (el-body)
(when el-body
(if (keywordp (car el-body))
(push (format nil " ~A=\""
(push (format nil " ~(~A~)=\""
(car el-body)) r)
(push (cadr el-body) r)
(push "\"" r)
......@@ -125,7 +126,7 @@
(if (or content (not (empty-tag-p (car form))))
(progn (push ">" r)
(when content (map nil #'process-form content))
(push (format nil "</~A>" (car form)) r))
(push (format nil "</~(~A~)>" (car form)) r))
(progn (when (eql *ps-html-mode* :xml)
(push "/" r))
(push ">" r))))))
......@@ -36,6 +36,7 @@
(in-package #:parenscript)
(named-readtables:in-readtable :parenscript)
;;; bind and bind* - macros used for destructuring bindings in PS LOOP
......@@ -421,7 +422,7 @@
(assert (eq (car master) :iter) nil "First clause is not master loop: ~a" master)
(let* ((firstvar (loop :for (tag nil init step) :in rest
:when (and (eq tag :iter) (not (tree-equal init step)))
:do (return (ps-gensym "first"))))
:do (return (ps-gensym 'FIRST))))
(body (build-body rest firstvar)))
(when firstvar
(setf body (append body `((setf ,firstvar nil)))))
......@@ -205,7 +205,7 @@
(let* ((fun-exp (car form))
(funobj (if (symbolp fun-exp)
(ps-gensym "funobj"))))
(ps-gensym 'funobj))))
`(let (,@(unless (symbolp fun-exp) `((,funobj ,fun-exp)))
(,prev-mv (if (undefined __PS_MV_REG)
(setf __PS_MV_REG undefined)
......@@ -399,10 +399,10 @@ lambda-list::=
(defpsmacro dolist ((var array &optional (result nil result?)) &body body)
(let* ((idx (ps-gensym "_JS_IDX"))
(let* ((idx (ps-gensym '_js_idx))
(introduce-array-var? (not (symbolp array)))
(arrvar (if introduce-array-var?
(ps-gensym "_JS_ARRVAR")
(ps-gensym '_js_arrvar)
`(do* (,var
,@(when introduce-array-var?
......@@ -476,7 +476,7 @@ lambda-list::=
(defpsmacro destructuring-bind (bindings expr &body body)
(setf bindings (dot->rest bindings))
(multiple-value-bind (declarations executable-body) (parse-body body)
(let* ((arr (if (hoist-expr? bindings expr) (ps-gensym "_DB") expr))
(let* ((arr (if (hoist-expr? bindings expr) (ps-gensym '_db) expr))
(bound (destructuring-wrap arr 0 bindings declarations
(cons 'progn executable-body))))
(cond ((eq arr expr) bound)
......@@ -38,13 +38,15 @@
(defvar *obfuscated-packages* (make-hash-table))
(defun obfuscate-package (package-designator &optional
(let ((symbol-table (make-hash-table)))
(lambda (symbol)
(or #1=(gethash symbol symbol-table)
(setf #1# (ps-gensym "G")))))))
(setf (gethash (find-package package-designator) *obfuscated-packages*) symbol-map))
(defun obfuscate-package (package-designator &optional symbol-map)
(setf (gethash (find-package package-designator)
(or symbol-map
(let ((symbol-table (make-hash-table)))
(lambda (symbol)
(or (gethash symbol symbol-table)
(setf (gethash symbol symbol-table)
(ps-gensym 'g))))))))
(defun unobfuscate-package (package-designator)
(remhash (find-package package-designator) *obfuscated-packages*))
......@@ -46,7 +46,9 @@
(unless (named-readtables:find-readtable :parenscript)
(named-readtables:defreadtable :parenscript
(:merge :standard)
(:case :invert))))
(:case #.(if (eql :upcase (readtable-case *readtable*))
(readtable-case *readtable*))))))
(named-readtables:in-readtable :parenscript)
......@@ -103,7 +105,7 @@
;; literals
#.(symbol-name 'nil) ; for case-sensitive Lisps like some versions of Allegro
;; array literals
......@@ -74,7 +74,7 @@
(defun fix-nary-comparison (operator objects)
(let* ((tmp-var-forms (butlast (cdr objects)))
(tmp-vars (loop repeat (length tmp-var-forms)
collect (ps-gensym "_CMP")))
collect (ps-gensym '_cmp)))
(all-comparisons (append (list (car objects))
(last objects))))
......@@ -118,7 +118,7 @@
(list ',op1 (compile-expression x)))
((references? delta x)
(let ((var (ps-gensym "_PS_INCR_PLACE")))
(let ((var (ps-gensym '_ps_incr_place)))
`(let ((,var ,delta))
(,',op ,x ,var)))))
......@@ -238,7 +238,7 @@
(let* ((cvalue (compile-expression value))
(val1 (unless (or (constantp cvalue)
(symbolp cvalue))
(ps-gensym "VAL1_"))))
(ps-gensym 'val1_))))
(let ((suppress-values? nil))
`(let ,(when val1 `((,val1 ,value)))
......@@ -96,12 +96,16 @@ Use GETPROP, @, or CHAIN instead."
(char-upcase c))
(setf lowercase t)))))))
((every #'upper-case-p
(remove-if-not #'alpha-char-p identifier))
(string-downcase identifier))
((every #'lower-case-p
(remove-if-not #'alpha-char-p identifier))
(string-upcase identifier))
(#.(eql :invert (readtable-case
(named-readtables:find-readtable :parenscript)))
((every #'upper-case-p
(remove-if-not #'alpha-char-p identifier))
(string-downcase identifier))
((every #'lower-case-p
(remove-if-not #'alpha-char-p identifier))
(string-upcase identifier))
(t identifier)))
(t identifier))))))
(defun ordered-set-difference (list1 list2 &key (test #'eql))
......@@ -874,17 +874,17 @@ for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
(test-ps-js the-html-generator-1
(ps-html ((:a :href "foobar") "blorg"))
"'<A HREF=\\\"foobar\\\">blorg</A>';")
"'<a href=\\\"foobar\\\">blorg</a>';")
(test-ps-js the-html-generator-2
(ps-html ((:a :href (generate-a-link)) "blorg"))
"['<A HREF=\\\"', generateALink(), '\\\">blorg</A>'].join('');")
"['<a href=\\\"', generateALink(), '\\\">blorg</a>'].join('');")
(test-ps-js the-html-generator-3
(funcall (getprop document 'write)
(ps-html ((:a :href "#"
:onclick (ps-inline (transport))) "link")))
"document.write(['<A HREF=\\\"#\\\" ONCLICK=\\\"', 'javascript:' + 'transport()', '\\\">link</A>'].join(''));")
"document.write(['<a href=\\\"#\\\" onclick=\\\"', 'javascript:' + 'transport()', '\\\">link</a>'].join(''));")
(test-ps-js the-html-generator-4
(let ((disabled nil)
......@@ -895,7 +895,7 @@ for (var _js1 = 0; _js1 < _js2; _js1 += 1) {
"(function () {
var disabled = null;
var authorized = true;
return element.innerHTML = ['<TEXTAREA', disabled || !authorized ? [' DISABLED=\\\"', 'disabled', '\\\"'].join('') : '', '>Edit me</TEXTAREA>'].join('');
return element.innerHTML = ['<textarea', disabled || !authorized ? [' disabled=\\\"', 'disabled', '\\\"'].join('') : '', '>Edit me</textarea>'].join('');
(test-ps-js plus-is-not-commutative
......@@ -1446,7 +1446,7 @@ __setf_someThing('foo', 1, 2);")
:onclick (ps-inline (transport)))
"document.write(LINKORNOT === 1 ? ['<A HREF=\\\"#\\\" ONCLICK=\\\"', 'javascript:' + 'transport()', '\\\">', img, '</A>'].join('') : img);")
"document.write(LINKORNOT === 1 ? ['<a href=\\\"#\\\" onclick=\\\"', 'javascript:' + 'transport()', '\\\">', img, '</a>'].join('') : img);")
(test-ps-js negate-number-literal
(- 1)
......@@ -1479,9 +1479,11 @@ __setf_someThing('foo', 1, 2);")
(test-ps-js ampersand-whole-1
(macrolet ((foo (&whole foo bar baz)
(declare (ignore bar baz))
(with-standard-io-syntax (format nil "~a" foo))))
(let ((*print-case* :downcase))
(format nil "~a" foo)))))
(foo 1 2))
"'(FOO 1 2)';")
"'(foo 1 2)';")
(test-ps-js ampersand-whole-2
(macrolet ((foo (&whole foo bar baz)
......@@ -1693,11 +1695,11 @@ __setf_someThing('foo', 1, 2);")
(:a :href ""
(:span :class "ticker-symbol-popup")))
"['<SPAN CLASS=\\\"ticker-symbol\\\" TICKER-SYMBOL=\\\"', symbol, '\\\"><A HREF=\\\"\\\">', symbol, '</A><SPAN CLASS=\\\"ticker-symbol-popup\\\"></SPAN></SPAN>'].join('');")
"['<span class=\\\"ticker-symbol\\\" ticker-symbol=\\\"', symbol, '\\\"><a href=\\\"\\\">', symbol, '</a><span class=\\\"ticker-symbol-popup\\\"></span></span>'].join('');")
(test-ps-js who-html2
(who-ps-html (:p "t0" (:span "t1")))
(test-ps-js flet1
((lambda () (flet ((foo (x)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment