Updated to work under Allegro Common Lisp

js/semantics/GrammarSymbol.lisp

@@ -345,7 +345,7 @@
 (defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
   (eql grammar-symbol1 grammar-symbol2))
 ; A version of grammar-symbol-= suitable for being the test function for hash tables.
-(defconstant *grammar-symbol-=* #'eql)
+(defparameter *grammar-symbol-=* #'eql)
 
 
 ; Return the general-grammar-symbol's symbol.  Return it unchanged if it is not

js/semantics/HTML.lisp

@@ -322,7 +322,7 @@
 ; Write html to the text file with the given name (relative to the
 ; local directory).
 (defun write-html-to-local-file (filename html)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :output
                           :if-exists :supersede
                           #+mcl :mac-file-creator #+mcl "MOSS")

js/semantics/JS14/Parser.lisp

@@ -384,17 +384,17 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS14;ParserGrammar.rtf"
+ "JS14/ParserGrammar.rtf"
  "JavaScript 1.4 Parser Grammar"
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";JS14;ParserGrammar.html"
+ "JS14/ParserGrammar.html"
  "JavaScript 1.4 Parser Grammar"
  t
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
-(with-local-output (s ";JS14;ParserGrammar.txt") (print-grammar *jg* s))
+(with-local-output (s "JS14/ParserGrammar.txt") (print-grammar *jg* s))
 |#

js/semantics/JS20/Lexer.lisp

@@ -524,7 +524,7 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS20;LexerCharClasses.rtf"
+ "JS20/LexerCharClasses.rtf"
  "JavaScript 2 Lexer Character Classes"
  #'(lambda (rtf-stream)
      (depict-paragraph (rtf-stream ':grammar-header)
@@ -537,33 +537,33 @@
 
 (progn
   (depict-rtf-to-local-file
-   ";JS20;LexerGrammar.rtf"
+   "JS20/LexerGrammar.rtf"
    "JavaScript 2 Lexer Grammar"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw* :visible-semantics nil)))
   (depict-rtf-to-local-file
-   ";JS20;LexerSemantics.rtf"
+   "JS20/LexerSemantics.rtf"
    "JavaScript 2 Lexer Semantics"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw*))))
 
 (progn
   (depict-html-to-local-file
-   ";JS20;LexerGrammar.html"
+   "JS20/LexerGrammar.html"
    "JavaScript 2 Lexer Grammar"
    t
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw* :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
-   ";JS20;LexerSemantics.html"
+   "JS20/LexerSemantics.html"
    "JavaScript 2 Lexer Semantics"
    t
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw*))
    :external-link-base "notation.html"))
 
-(with-local-output (s ";JS20;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
 
 (print-illegal-strings m)
 |#

js/semantics/JS20/Parser.lisp

@@ -634,21 +634,21 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS20;ParserGrammar.rtf"
+ "JS20/ParserGrammar.rtf"
  "JavaScript 2.0 Parser Grammar"
  #'(lambda (markup-stream)
      (depict-js-terminals markup-stream *jg*)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";JS20;ParserGrammar.html"
+ "JS20/ParserGrammar.html"
  "JavaScript 2.0 Parser Grammar"
  t
  #'(lambda (markup-stream)
      (depict-js-terminals markup-stream *jg*)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
-(with-local-output (s ";JS20;ParserGrammar.txt") (print-grammar *jg* s))
+(with-local-output (s "JS20/ParserGrammar.txt") (print-grammar *jg* s))
 |#
 
 (length (grammar-states *jg*))

js/semantics/JS20/RegExp.lisp

@@ -586,33 +586,33 @@
 #|
 (progn
   (depict-rtf-to-local-file
-   ";JS20;RegExpGrammar.rtf"
+   "JS20/RegExpGrammar.rtf"
    "Regular Expression Grammar"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *rw* :visible-semantics nil)))
   (depict-rtf-to-local-file
-   ";JS20;RegExpSemantics.rtf"
+   "JS20/RegExpSemantics.rtf"
    "Regular Expression Semantics"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *rw*))))
 
 (progn
   (depict-html-to-local-file
-   ";JS20;RegExpGrammar.html"
+   "JS20/RegExpGrammar.html"
    "Regular Expression Grammar"
    t
    #'(lambda (html-stream)
        (depict-world-commands html-stream *rw* :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
-   ";JS20;RegExpSemantics.html"
+   "JS20/RegExpSemantics.html"
    "Regular Expression Semantics"
    t
    #'(lambda (html-stream)
        (depict-world-commands html-stream *rw*))
    :external-link-base "notation.html"))
 
-(with-local-output (s ";JS20;RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
+(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
 
 (lexer-pparse *rl* "a+" :trace t)
 (lexer-pparse *rl* "[]+" :trace t)

js/semantics/JSECMA/Lexer.lisp

@@ -428,7 +428,7 @@
 
 #|
 (depict-rtf-to-local-file
- ";JSECMA;LexerCharClasses.rtf"
+ "JSECMA/LexerCharClasses.rtf"
  "ECMAScript 1 Lexer Character Classes"
  #'(lambda (rtf-stream)
      (depict-paragraph (rtf-stream ':grammar-header)
@@ -440,19 +440,19 @@
      (depict-grammar rtf-stream *lg*)))
 
 (depict-rtf-to-local-file
- ";JSECMA;LexerSemantics.rtf"
+ "JSECMA/LexerSemantics.rtf"
  "ECMAScript 1 Lexer Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *lw*)))
 
 (depict-html-to-local-file
- ";JSECMA;LexerSemantics.html"
+ "JSECMA/LexerSemantics.html"
  "ECMAScript 1 Lexer Semantics"
  t
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *lw*)))
 
-(with-local-output (s ";JSECMA;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+(with-local-output (s "JSECMA/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
 
 (print-illegal-strings m)
 

js/semantics/JSECMA/Parser.lisp

@@ -829,19 +829,19 @@
 
 #|
 (depict-rtf-to-local-file
- ";JSECMA;ParserSemantics.rtf"
+ "JSECMA/ParserSemantics.rtf"
  "ECMAScript 1 Parser Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *gw*)))
 
 (depict-html-to-local-file
- ";JSECMA;ParserSemantics.html"
+ "JSECMA/ParserSemantics.html"
  "ECMAScript 1 Parser Semantics"
  t
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *gw*)))
 
-(with-local-output (s ";JSECMA;ParserGrammar.txt") (print-grammar *gg* s))
+(with-local-output (s "JSECMA/ParserGrammar.txt") (print-grammar *gg* s))
 
 
 (ecma-pparse "('abc')")

js/semantics/Main.lisp

@@ -24,24 +24,62 @@
 ;;;
 
 
+#+allegro (shadow 'state)
+#+allegro (shadow 'type)
+
 (defparameter *semantic-engine-filenames*
-  '("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"
-    ";JS20;Parser" ";JS20;Lexer" ";JS20;RegExp" #|"JSECMA;Lexer" "JSECMA;Parser"|# ))
+  '("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"))
+
+(defparameter *semantics-filenames*
+  '("JS20/Parser" "JS20/Lexer" "JS20/RegExp" #|"JSECMA/Lexer" "JSECMA/Parser"|# ))
 
 (defparameter *semantic-engine-directory*
   (make-pathname 
-   :directory (pathname-directory (truename *loading-file-source-file*))))
+   :directory (pathname-directory #-mcl *load-truename*
+                                  #+mcl (truename *loading-file-source-file*))))
+
+
+;;; Convert a filename string possibly containing slashes into a Lisp relative pathname.
+(defun filename-to-relative-pathname (filename)
+  (let ((directories nil))
+    (loop
+      (let ((slash (position #\/ filename)))
+        (if slash
+          (progn
+            (push (subseq filename 0 slash) directories)
+            (setq filename (subseq filename (1+ slash))))
+          (return (if directories
+                    (make-pathname :directory (cons ':relative (nreverse directories)) :name filename)
+                    filename)))))))
+
+
+;;; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
+;;; into a Lisp absolute pathname.
+(defun filename-to-semantic-engine-pathname (filename)
+  (merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
+
+
+(defun operate-on-files (f files &rest options)
+  (with-compilation-unit ()
+    (dolist (filename files)
+      (apply f (filename-to-semantic-engine-pathname filename) :verbose t options))))
+
+(defun compile-semantic-engine ()
+  (operate-on-files #'compile-file *semantic-engine-filenames* :load t))
 
 (defun load-semantic-engine ()
-  (dolist (filename *semantic-engine-filenames*)
-    (let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
-      (load pathname :verbose t))))
+  (operate-on-files #-allegro #'load #+allegro #'load-compiled *semantic-engine-filenames*))
+
+(defun load-semantics ()
+  (operate-on-files #'load *semantics-filenames*))
+
 
 (defmacro with-local-output ((stream filename) &body body)
-  `(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
+  `(with-open-file (,stream (filename-to-semantic-engine-pathname ,filename)
                             :direction :output
                             :if-exists :supersede)
      ,@body))
 
 
 (load-semantic-engine)
+(load-semantics)

js/semantics/Markup.lisp

@@ -225,14 +225,14 @@
   (substitute-soft-breaks
    tree
    #'(lambda (soft-break)
-       (list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
+       (list (make-string (soft-break-width soft-break) :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
 
 
 ; Return a freshly consed markup list for a hard line break followed by indent spaces.
 (defun hard-break-markup (indent)
   (if (zerop indent)
     (list ':new-line)
-    (list ':new-line (make-string indent :initial-element #\space :element-type 'base-character))))
+    (list ':new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
 
 
 ; Destructively replace any soft-break that appears in a car position in the tree
@@ -600,7 +600,7 @@
 ; The string should contain only letters, dashes, and numbers.
 (defun string-to-mixed-case (string &optional capitalize)
   (let* ((length (length string))
-         (dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
+         (dst-string (make-array length :element-type #-mcl 'character #+mcl 'base-character :fill-pointer 0)))
     (dotimes (i length)
       (let ((char (char string i)))
         (if (eql char #\-)

js/semantics/RTF.lisp

@@ -355,8 +355,8 @@
 ; (an output stream), dividing the text as specified by dynamically scoped calls
 ; to break-line.  Return the text as a base-string.
 (defun write-limited-lines (emitter)
-  (let ((limited-stream (make-string-output-stream :element-type 'base-character))
-        (*current-limited-lines* (make-string-output-stream :element-type 'base-character))
+  (let ((limited-stream (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
+        (*current-limited-lines* (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
         (*current-limited-lines-non-empty* nil)
         (*current-limited-position* 0))
     (funcall emitter limited-stream)
@@ -525,7 +525,7 @@
 ; Read RTF from the text file with the given name (relative to the
 ; local directory) and return it in list form.
 (defun read-rtf-from-local-file (filename)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :input)
     (read-rtf stream)))
 
@@ -543,7 +543,7 @@
   (let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
     (if i
       (let* ((string-length (length string))
-             (result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
+             (result-string (make-array string-length :element-type #-mcl 'character #+mcl 'base-character :adjustable t :fill-pointer i)))
         (replace result-string string)
         (do ((i i (1+ i)))
             ((= i string-length))
@@ -632,7 +632,7 @@
 ; Write RTF to the text file with the given name (relative to the
 ; local directory).
 (defun write-rtf-to-local-file (filename rtf)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :output
                           :if-exists :supersede
                           #+mcl :external-format #+mcl "RTF "

js/semantics/Test/BaseExample.lisp

@@ -45,13 +45,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;BaseExampleSemantics.rtf"
+ "Test/BaseExampleSemantics.rtf"
  "Base Example Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *bew*)))
 
 (depict-html-to-local-file
- ";Test;BaseExampleSemantics.html"
+ "Test/BaseExampleSemantics.html"
  "Base Example Semantics"
  t
  #'(lambda (html-stream)

js/semantics/Test/ConstraintTest.lisp

@@ -51,19 +51,19 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;ConstraintTestGrammar.rtf"
+ "Test/ConstraintTestGrammar.rtf"
  "Constraint Test Grammar"
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";Test;ConstraintTestGrammar.html"
+ "Test/ConstraintTestGrammar.html"
  "Constraint Test Grammar"
  t
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
 
-(with-local-output (s ";Test;ConstraintTestGrammar.txt") (print-grammar *ctg* s))
+(with-local-output (s "Test/ConstraintTestGrammar.txt") (print-grammar *ctg* s))
 
 (pprint (parse *ctg* #'identity '(begin letter letter letter digit end)))
 |#

js/semantics/Test/StandardFunction.lisp

@@ -20,13 +20,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;StandardFunctionSemantics.rtf"
+ "Test/StandardFunctionSemantics.rtf"
  "Standard Function Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *sfw*)))
 
 (depict-html-to-local-file
- ";Test;StandardFunctionSemantics.html"
+ "Test/StandardFunctionSemantics.html"
  "Standard Function Semantics"
  t
  #'(lambda (html-stream)

js/semantics/Test/ThrowCatch.lisp

@@ -33,13 +33,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;ThrowCatchSemantics.rtf"
+ "Test/ThrowCatchSemantics.rtf"
  "Base Example Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *tcw*)))
 
 (depict-html-to-local-file
- ";Test;ThrowCatchSemantics.html"
+ "Test/ThrowCatchSemantics.html"
  "Base Example Semantics"
  t
  #'(lambda (html-stream)

js/semantics/Utilities.lisp

@@ -155,7 +155,8 @@
 ;;; ------------------------------------------------------------------------------------------------------
 ;;; VALUE ASSERTS
 
-(defconstant *value-asserts* t)
+(eval-when (:compile-toplevel :load-toplevel)
+  (defconstant *value-asserts* t))
 
 ; Assert that (test value) returns non-nil.  Return value.
 (defmacro assert-value (value test &rest format-and-parameters)

js2/semantics/GrammarSymbol.lisp

@@ -345,7 +345,7 @@
 (defun grammar-symbol-= (grammar-symbol1 grammar-symbol2)
   (eql grammar-symbol1 grammar-symbol2))
 ; A version of grammar-symbol-= suitable for being the test function for hash tables.
-(defconstant *grammar-symbol-=* #'eql)
+(defparameter *grammar-symbol-=* #'eql)
 
 
 ; Return the general-grammar-symbol's symbol.  Return it unchanged if it is not

js2/semantics/HTML.lisp

@@ -322,7 +322,7 @@
 ; Write html to the text file with the given name (relative to the
 ; local directory).
 (defun write-html-to-local-file (filename html)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :output
                           :if-exists :supersede
                           #+mcl :mac-file-creator #+mcl "MOSS")

js2/semantics/JS14/Parser.lisp

@@ -384,17 +384,17 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS14;ParserGrammar.rtf"
+ "JS14/ParserGrammar.rtf"
  "JavaScript 1.4 Parser Grammar"
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";JS14;ParserGrammar.html"
+ "JS14/ParserGrammar.html"
  "JavaScript 1.4 Parser Grammar"
  t
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
-(with-local-output (s ";JS14;ParserGrammar.txt") (print-grammar *jg* s))
+(with-local-output (s "JS14/ParserGrammar.txt") (print-grammar *jg* s))
 |#

js2/semantics/JS20/Lexer.lisp

@@ -524,7 +524,7 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS20;LexerCharClasses.rtf"
+ "JS20/LexerCharClasses.rtf"
  "JavaScript 2 Lexer Character Classes"
  #'(lambda (rtf-stream)
      (depict-paragraph (rtf-stream ':grammar-header)
@@ -537,33 +537,33 @@
 
 (progn
   (depict-rtf-to-local-file
-   ";JS20;LexerGrammar.rtf"
+   "JS20/LexerGrammar.rtf"
    "JavaScript 2 Lexer Grammar"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw* :visible-semantics nil)))
   (depict-rtf-to-local-file
-   ";JS20;LexerSemantics.rtf"
+   "JS20/LexerSemantics.rtf"
    "JavaScript 2 Lexer Semantics"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw*))))
 
 (progn
   (depict-html-to-local-file
-   ";JS20;LexerGrammar.html"
+   "JS20/LexerGrammar.html"
    "JavaScript 2 Lexer Grammar"
    t
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw* :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
-   ";JS20;LexerSemantics.html"
+   "JS20/LexerSemantics.html"
    "JavaScript 2 Lexer Semantics"
    t
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *lw*))
    :external-link-base "notation.html"))
 
-(with-local-output (s ";JS20;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+(with-local-output (s "JS20/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
 
 (print-illegal-strings m)
 |#

js2/semantics/JS20/Parser.lisp

@@ -634,21 +634,21 @@
 
 #|
 (depict-rtf-to-local-file
- ";JS20;ParserGrammar.rtf"
+ "JS20/ParserGrammar.rtf"
  "JavaScript 2.0 Parser Grammar"
  #'(lambda (markup-stream)
      (depict-js-terminals markup-stream *jg*)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";JS20;ParserGrammar.html"
+ "JS20/ParserGrammar.html"
  "JavaScript 2.0 Parser Grammar"
  t
  #'(lambda (markup-stream)
      (depict-js-terminals markup-stream *jg*)
      (depict-world-commands markup-stream *jw* :visible-semantics nil)))
 
-(with-local-output (s ";JS20;ParserGrammar.txt") (print-grammar *jg* s))
+(with-local-output (s "JS20/ParserGrammar.txt") (print-grammar *jg* s))
 |#
 
 (length (grammar-states *jg*))

js2/semantics/JS20/RegExp.lisp

@@ -586,33 +586,33 @@
 #|
 (progn
   (depict-rtf-to-local-file
-   ";JS20;RegExpGrammar.rtf"
+   "JS20/RegExpGrammar.rtf"
    "Regular Expression Grammar"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *rw* :visible-semantics nil)))
   (depict-rtf-to-local-file
-   ";JS20;RegExpSemantics.rtf"
+   "JS20/RegExpSemantics.rtf"
    "Regular Expression Semantics"
    #'(lambda (rtf-stream)
        (depict-world-commands rtf-stream *rw*))))
 
 (progn
   (depict-html-to-local-file
-   ";JS20;RegExpGrammar.html"
+   "JS20/RegExpGrammar.html"
    "Regular Expression Grammar"
    t
    #'(lambda (html-stream)
        (depict-world-commands html-stream *rw* :visible-semantics nil))
    :external-link-base "notation.html")
   (depict-html-to-local-file
-   ";JS20;RegExpSemantics.html"
+   "JS20/RegExpSemantics.html"
    "Regular Expression Semantics"
    t
    #'(lambda (html-stream)
        (depict-world-commands html-stream *rw*))
    :external-link-base "notation.html"))
 
-(with-local-output (s ";JS20;RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
+(with-local-output (s "JS20/RegExpGrammar.txt") (print-lexer *rl* s) (print-grammar *rg* s))
 
 (lexer-pparse *rl* "a+" :trace t)
 (lexer-pparse *rl* "[]+" :trace t)

js2/semantics/JSECMA/Lexer.lisp

@@ -428,7 +428,7 @@
 
 #|
 (depict-rtf-to-local-file
- ";JSECMA;LexerCharClasses.rtf"
+ "JSECMA/LexerCharClasses.rtf"
  "ECMAScript 1 Lexer Character Classes"
  #'(lambda (rtf-stream)
      (depict-paragraph (rtf-stream ':grammar-header)
@@ -440,19 +440,19 @@
      (depict-grammar rtf-stream *lg*)))
 
 (depict-rtf-to-local-file
- ";JSECMA;LexerSemantics.rtf"
+ "JSECMA/LexerSemantics.rtf"
  "ECMAScript 1 Lexer Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *lw*)))
 
 (depict-html-to-local-file
- ";JSECMA;LexerSemantics.html"
+ "JSECMA/LexerSemantics.html"
  "ECMAScript 1 Lexer Semantics"
  t
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *lw*)))
 
-(with-local-output (s ";JSECMA;LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
+(with-local-output (s "JSECMA/LexerGrammar.txt") (print-lexer *ll* s) (print-grammar *lg* s))
 
 (print-illegal-strings m)
 

js2/semantics/JSECMA/Parser.lisp

@@ -829,19 +829,19 @@
 
 #|
 (depict-rtf-to-local-file
- ";JSECMA;ParserSemantics.rtf"
+ "JSECMA/ParserSemantics.rtf"
  "ECMAScript 1 Parser Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *gw*)))
 
 (depict-html-to-local-file
- ";JSECMA;ParserSemantics.html"
+ "JSECMA/ParserSemantics.html"
  "ECMAScript 1 Parser Semantics"
  t
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *gw*)))
 
-(with-local-output (s ";JSECMA;ParserGrammar.txt") (print-grammar *gg* s))
+(with-local-output (s "JSECMA/ParserGrammar.txt") (print-grammar *gg* s))
 
 
 (ecma-pparse "('abc')")

js2/semantics/Main.lisp

@@ -24,24 +24,62 @@
 ;;;
 
 
+#+allegro (shadow 'state)
+#+allegro (shadow 'type)
+
 (defparameter *semantic-engine-filenames*
-  '("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"
-    ";JS20;Parser" ";JS20;Lexer" ";JS20;RegExp" #|"JSECMA;Lexer" "JSECMA;Parser"|# ))
+  '("Utilities" "Markup" "RTF" "HTML" "GrammarSymbol" "Grammar" "Parser" "Metaparser" "Lexer" "Calculus" "CalculusMarkup"))
+
+(defparameter *semantics-filenames*
+  '("JS20/Parser" "JS20/Lexer" "JS20/RegExp" #|"JSECMA/Lexer" "JSECMA/Parser"|# ))
 
 (defparameter *semantic-engine-directory*
   (make-pathname 
-   :directory (pathname-directory (truename *loading-file-source-file*))))
+   :directory (pathname-directory #-mcl *load-truename*
+                                  #+mcl (truename *loading-file-source-file*))))
+
+
+;;; Convert a filename string possibly containing slashes into a Lisp relative pathname.
+(defun filename-to-relative-pathname (filename)
+  (let ((directories nil))
+    (loop
+      (let ((slash (position #\/ filename)))
+        (if slash
+          (progn
+            (push (subseq filename 0 slash) directories)
+            (setq filename (subseq filename (1+ slash))))
+          (return (if directories
+                    (make-pathname :directory (cons ':relative (nreverse directories)) :name filename)
+                    filename)))))))
+
+
+;;; Convert a filename string possibly containing slashes relative to *semantic-engine-directory*
+;;; into a Lisp absolute pathname.
+(defun filename-to-semantic-engine-pathname (filename)
+  (merge-pathnames (filename-to-relative-pathname filename) *semantic-engine-directory*))
+
+
+(defun operate-on-files (f files &rest options)
+  (with-compilation-unit ()
+    (dolist (filename files)
+      (apply f (filename-to-semantic-engine-pathname filename) :verbose t options))))
+
+(defun compile-semantic-engine ()
+  (operate-on-files #'compile-file *semantic-engine-filenames* :load t))
 
 (defun load-semantic-engine ()
-  (dolist (filename *semantic-engine-filenames*)
-    (let ((pathname (merge-pathnames filename *semantic-engine-directory*)))
-      (load pathname :verbose t))))
+  (operate-on-files #-allegro #'load #+allegro #'load-compiled *semantic-engine-filenames*))
+
+(defun load-semantics ()
+  (operate-on-files #'load *semantics-filenames*))
+
 
 (defmacro with-local-output ((stream filename) &body body)
-  `(with-open-file (,stream (merge-pathnames ,filename *semantic-engine-directory*)
+  `(with-open-file (,stream (filename-to-semantic-engine-pathname ,filename)
                             :direction :output
                             :if-exists :supersede)
      ,@body))
 
 
 (load-semantic-engine)
+(load-semantics)

js2/semantics/Markup.lisp

@@ -225,14 +225,14 @@
   (substitute-soft-breaks
    tree
    #'(lambda (soft-break)
-       (list (make-string (soft-break-width soft-break) :initial-element #\space :element-type 'base-character)))))
+       (list (make-string (soft-break-width soft-break) :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character)))))
 
 
 ; Return a freshly consed markup list for a hard line break followed by indent spaces.
 (defun hard-break-markup (indent)
   (if (zerop indent)
     (list ':new-line)
-    (list ':new-line (make-string indent :initial-element #\space :element-type 'base-character))))
+    (list ':new-line (make-string indent :initial-element #\space :element-type #-mcl 'character #+mcl 'base-character))))
 
 
 ; Destructively replace any soft-break that appears in a car position in the tree
@@ -600,7 +600,7 @@
 ; The string should contain only letters, dashes, and numbers.
 (defun string-to-mixed-case (string &optional capitalize)
   (let* ((length (length string))
-         (dst-string (make-array length :element-type 'base-character :fill-pointer 0)))
+         (dst-string (make-array length :element-type #-mcl 'character #+mcl 'base-character :fill-pointer 0)))
     (dotimes (i length)
       (let ((char (char string i)))
         (if (eql char #\-)

js2/semantics/RTF.lisp

@@ -355,8 +355,8 @@
 ; (an output stream), dividing the text as specified by dynamically scoped calls
 ; to break-line.  Return the text as a base-string.
 (defun write-limited-lines (emitter)
-  (let ((limited-stream (make-string-output-stream :element-type 'base-character))
-        (*current-limited-lines* (make-string-output-stream :element-type 'base-character))
+  (let ((limited-stream (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
+        (*current-limited-lines* (make-string-output-stream :element-type #-mcl 'character #+mcl 'base-character))
         (*current-limited-lines-non-empty* nil)
         (*current-limited-position* 0))
     (funcall emitter limited-stream)
@@ -525,7 +525,7 @@
 ; Read RTF from the text file with the given name (relative to the
 ; local directory) and return it in list form.
 (defun read-rtf-from-local-file (filename)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :input)
     (read-rtf stream)))
 
@@ -543,7 +543,7 @@
   (let ((i (position-if #'(lambda (char) (member char *rtf-special*)) string)))
     (if i
       (let* ((string-length (length string))
-             (result-string (make-array string-length :element-type 'base-character :adjustable t :fill-pointer i)))
+             (result-string (make-array string-length :element-type #-mcl 'character #+mcl 'base-character :adjustable t :fill-pointer i)))
         (replace result-string string)
         (do ((i i (1+ i)))
             ((= i string-length))
@@ -632,7 +632,7 @@
 ; Write RTF to the text file with the given name (relative to the
 ; local directory).
 (defun write-rtf-to-local-file (filename rtf)
-  (with-open-file (stream (merge-pathnames filename *semantic-engine-directory*)
+  (with-open-file (stream (filename-to-semantic-engine-pathname filename)
                           :direction :output
                           :if-exists :supersede
                           #+mcl :external-format #+mcl "RTF "

js2/semantics/Test/BaseExample.lisp

@@ -45,13 +45,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;BaseExampleSemantics.rtf"
+ "Test/BaseExampleSemantics.rtf"
  "Base Example Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *bew*)))
 
 (depict-html-to-local-file
- ";Test;BaseExampleSemantics.html"
+ "Test/BaseExampleSemantics.html"
  "Base Example Semantics"
  t
  #'(lambda (html-stream)

js2/semantics/Test/ConstraintTest.lisp

@@ -51,19 +51,19 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;ConstraintTestGrammar.rtf"
+ "Test/ConstraintTestGrammar.rtf"
  "Constraint Test Grammar"
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
 
 (depict-html-to-local-file
- ";Test;ConstraintTestGrammar.html"
+ "Test/ConstraintTestGrammar.html"
  "Constraint Test Grammar"
  t
  #'(lambda (markup-stream)
      (depict-world-commands markup-stream *ctw* :visible-semantics nil)))
 
-(with-local-output (s ";Test;ConstraintTestGrammar.txt") (print-grammar *ctg* s))
+(with-local-output (s "Test/ConstraintTestGrammar.txt") (print-grammar *ctg* s))
 
 (pprint (parse *ctg* #'identity '(begin letter letter letter digit end)))
 |#

js2/semantics/Test/StandardFunction.lisp

@@ -20,13 +20,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;StandardFunctionSemantics.rtf"
+ "Test/StandardFunctionSemantics.rtf"
  "Standard Function Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *sfw*)))
 
 (depict-html-to-local-file
- ";Test;StandardFunctionSemantics.html"
+ "Test/StandardFunctionSemantics.html"
  "Standard Function Semantics"
  t
  #'(lambda (html-stream)

js2/semantics/Test/ThrowCatch.lisp

@@ -33,13 +33,13 @@
 
 #|
 (depict-rtf-to-local-file
- ";Test;ThrowCatchSemantics.rtf"
+ "Test/ThrowCatchSemantics.rtf"
  "Base Example Semantics"
  #'(lambda (rtf-stream)
      (depict-world-commands rtf-stream *tcw*)))
 
 (depict-html-to-local-file
- ";Test;ThrowCatchSemantics.html"
+ "Test/ThrowCatchSemantics.html"
  "Base Example Semantics"
  t
  #'(lambda (html-stream)

js2/semantics/Utilities.lisp

@@ -155,7 +155,8 @@
 ;;; ------------------------------------------------------------------------------------------------------
 ;;; VALUE ASSERTS
 
-(defconstant *value-asserts* t)
+(eval-when (:compile-toplevel :load-toplevel)
+  (defconstant *value-asserts* t))
 
 ; Assert that (test value) returns non-nil.  Return value.
 (defmacro assert-value (value test &rest format-and-parameters)