#lang at-exp racket/base
(require algol60/algol60
         rackunit
         (for-syntax racket/base))

(define-syntax (capture-output stx)
  (syntax-case stx ()
    [(_ exp)
     (parameterize ([error-print-source-location #f])
       (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
  }))
