From c0b928c758cc64b7b902fbe38838d31a3c1bc008 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 20 Jun 2012 10:27:28 -0500
Subject: [PATCH] Added @literal-algol{} and started an algol60 test suite
 (apologies if there already was one that I didn't find). Also fixed syntax
 error raising procedure.

closes PR 12859
---
 collects/algol60/algol60.rkt    | 19 ++++++++++-
 collects/algol60/algol60.scrbl  | 19 +++++++++++
 collects/algol60/cfg-parser.rkt |  2 +-
 collects/algol60/parse.rkt      |  4 +--
 collects/tests/algol60/test.rkt | 60 +++++++++++++++++++++++++++++++++
 5 files changed, 100 insertions(+), 4 deletions(-)
 create mode 100644 collects/tests/algol60/test.rkt

diff --git a/collects/algol60/algol60.rkt b/collects/algol60/algol60.rkt
index c6b7eb573d..e15e94a982 100644
--- a/collects/algol60/algol60.rkt
+++ b/collects/algol60/algol60.rkt
@@ -20,7 +20,7 @@
      (require "runtime.rkt" "prims.rkt")
 
 
-     (provide include-algol)
+     (provide include-algol literal-algol)
 
      (define-syntax (include-algol stx)
        (syntax-case stx ()
@@ -35,4 +35,21 @@
 			      (current-load-relative-directory)
 			      (current-directory))))
 	    #'here)
+	   #'here)]))
+     
+     (define-syntax (literal-algol stx)
+       (syntax-case stx ()
+         [(_ strs ...)
+          (andmap (λ (x) (string? (syntax-e x))) 
+                  (syntax->list (syntax (strs ...))))
+          
+	  (compile-simplified
+	   (simplify 
+	    (parse-a60-port
+             (open-input-string 
+              (apply 
+               string-append
+               (map syntax-e (syntax->list #'(strs ...)))))
+             (syntax-source stx))
+	    #'here)
 	   #'here)])))
diff --git a/collects/algol60/algol60.scrbl b/collects/algol60/algol60.scrbl
index 561b1cdda7..354c3df44c 100644
--- a/collects/algol60/algol60.scrbl
+++ b/collects/algol60/algol60.scrbl
@@ -26,6 +26,25 @@ closed (i.e., it doesn't see any bindings in the included context),
 and the result is always @|void-const|.}
 
 
+@defform[(literal-algol string ...)]{
+
+Evaluates the Algol 60 program indicated by the literal @racket[string]s
+as an expression in a Racket program. The Algol 60 program is
+closed (i.e., it doesn't see any bindings in the included context),
+and the result is always @|void-const|.
+
+This is generally useful when combined with the @racketmodname[at-exp] reader,
+e.g.,
+@codeblock|{
+#lang at-exp racket
+@literal-algol{
+  begin
+    printsln (`hello world')
+  end
+}
+}|
+}
+
 @section{Language}
 
 The DrRacket and @racket[include-algol] implementation departs from
diff --git a/collects/algol60/cfg-parser.rkt b/collects/algol60/cfg-parser.rkt
index aa7438efc3..8309fb8b51 100644
--- a/collects/algol60/cfg-parser.rkt
+++ b/collects/algol60/cfg-parser.rkt
@@ -485,7 +485,7 @@
       [(_ clause ...)
        (let ([clauses (syntax->list #'(clause ...))])
          (let-values ([(start grammar cfg-error parser-clauses)
-		       (let ([all-toks (apply
+                       (let ([all-toks (apply
 					append
 					(map (lambda (clause)
 					       (syntax-case clause (tokens)
diff --git a/collects/algol60/parse.rkt b/collects/algol60/parse.rkt
index e41ae2e39a..db52594448 100644
--- a/collects/algol60/parse.rkt
+++ b/collects/algol60/parse.rkt
@@ -125,8 +125,8 @@
         (tokens non-terminals)
         (start <program>)
         (end EOF)
-        (error (lambda (a b stx) 
-		 (raise-read-error (format "parse error near ~a" (syntax-e stx))
+        (error (lambda (_ name stx start end) 
+                 (raise-read-error (format "parse error near ~a" name)
 				   (syntax-source stx)
 				   (syntax-line stx)
 				   (syntax-column stx)
diff --git a/collects/tests/algol60/test.rkt b/collects/tests/algol60/test.rkt
new file mode 100644
index 0000000000..2b5d4e31a9
--- /dev/null
+++ b/collects/tests/algol60/test.rkt
@@ -0,0 +1,60 @@
+#lang at-exp racket/base
+(require algol60/algol60
+         rackunit
+         (for-syntax racket/base))
+
+(define-syntax (capture-output stx)
+  (syntax-case stx ()
+    [(_ exp)
+     (with-handlers ((exn:fail?
+                      (λ (exn)
+                        #`(list 'expand
+                                #,(exn-message exn)))))
+       (define expanded (local-expand #'exp 'expression #f))
+       #`(let ([op (open-output-string)]
+               [ep (open-output-string)])
+           (let/ec k
+             (parameterize ([current-output-port op]
+                            [current-error-port ep]
+                            [error-escape-handler (λ () (k (void)))])
+               #,expanded))
+           (list 'run
+                 (get-output-string op)
+                 (get-output-string ep))))]))
+
+(check-equal?
+ (capture-output
+  @literal-algol{
+begin
+  printsln (`hello world')
+end
+})
+ '(run "hello world\n" ""))
+
+(check-pred
+ (λ (x) (and (eq? (list-ref x 0) 'expand)
+             (regexp-match #rx"parse error near BEGIN"
+                           (list-ref x 1))))
+ (capture-output
+  @literal-algol{
+begin
+}))
+
+
+(check-pred
+ (λ (x) (and (eq? (list-ref x 0) 'expand)
+             (regexp-match #rx"parse error near PROCEDURE"
+                           (list-ref x 1))))
+ (capture-output
+  @literal-algol{
+procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k);
+   value n, m; array a; integer n, m, i, k; real y;
+begin integer p, q;
+   y := 0; i := k := 1;
+   for p:=1 step 1 until n do
+   for q:=1 step 1 until m do
+       if abs(a[p, q]) > y then
+           begin y := abs(a[p, q]);
+           i := p; k := q
+           end
+end Absmax}))