├── tests
    ├── export.rkt
    ├── syncheck-test.rkt
    └── test.rkt
├── .gitignore
├── lang
    ├── algol60.rkt
    └── reader.rkt
├── cfg-parser.rkt
├── base.rkt
├── examples
    ├── jensen.a60
    ├── euler.a60
    ├── primes.a60
    └── nqueen.a60
├── LICENSE
├── README.md
├── info.rkt
├── algol60.rkt
├── prims.rkt
├── algol60.scrbl
├── runtime.rkt
├── tool.rkt
├── simplify.rkt
├── parse.rkt
└── compile.rkt


/tests/export.rkt:
--------------------------------------------------------------------------------
1 | #lang algol60
2 | begin
3 |   procedure f(x); begin f := 1 / x; end;
4 | end
5 | 


--------------------------------------------------------------------------------
/.gitignore:
--------------------------------------------------------------------------------
 1 | # Racket compiled files
 2 | compiled/
 3 | 
 4 | # common backups, autosaves, lock files, OS meta-files
 5 | *~
 6 | \#*
 7 | .#*
 8 | .DS_Store
 9 | *.bak
10 | TAGS
11 | 


--------------------------------------------------------------------------------
/lang/algol60.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 | 
3 | (require "../runtime.rkt"
4 |          "../prims.rkt")
5 | 
6 | (provide (all-from-out racket/base)
7 |          (all-from-out "../prims.rkt")
8 |          (all-from-out "../runtime.rkt"))
9 | 


--------------------------------------------------------------------------------
/cfg-parser.rkt:
--------------------------------------------------------------------------------
1 | #lang racket/base
2 | 
3 | ;; Legacy module.  cfg-parser used to live in the algol60 collection.
4 | ;; This module re-exports its contents for backwards compatibility.
5 | 
6 | (require parser-tools/cfg-parser)
7 | (provide (all-from-out parser-tools/cfg-parser))
8 | 


--------------------------------------------------------------------------------
/base.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | (require "prims.rkt"
 3 |          "runtime.rkt")
 4 | 
 5 | (define base-importing-stx #'here)
 6 | 
 7 | (provide (all-from-out racket)
 8 |          (all-from-out "prims.rkt")
 9 |          (all-from-out "runtime.rkt")
10 |          base-importing-stx)
11 | 


--------------------------------------------------------------------------------
/examples/jensen.a60:
--------------------------------------------------------------------------------
 1 | #lang algol60
 2 | 
 3 | begin
 4 |   integer procedure SIGMA(x, i, n);
 5 |     value n;
 6 |     integer x, i, n;
 7 |   begin
 8 |     integer sum;
 9 |     sum:=0;
10 |     for i:=1 step 1 until n do
11 |         sum:=sum+x;
12 |     SIGMA:=sum;
13 |   end;
14 |   integer q;
15 |   printnln(SIGMA(q*2-1, q, 7));
16 | end
17 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | This component of Racket is distributed under the under the Apache 2.0
 2 | and MIT licenses. The user can choose the license under which they
 3 | will be using the software. There may be other licenses within the
 4 | distribution with which the user must also comply.
 5 | 
 6 | See the files
 7 |   https://github.com/racket/racket/blob/master/racket/src/LICENSE-APACHE.txt
 8 | and
 9 |   https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt
10 | for the full text of the licenses.
11 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # algol60
 2 | 
 3 | This the source for the Racket package: "algol60".
 4 | 
 5 | ### Contributing
 6 | 
 7 | Contribute to Racket by submitting a [pull request], reporting an
 8 | [issue], joining the [development mailing list], or visiting the
 9 | IRC or Slack channels.
10 | 
11 | ### License
12 | 
13 | Racket, including these packages, is free software, see [LICENSE]
14 | for more details.
15 | 
16 | By making a contribution, you are agreeing that your contribution
17 | is licensed under the [Apache 2.0] license and the [MIT] license.
18 | 
19 | [MIT]: https://github.com/racket/racket/blob/master/racket/src/LICENSE-MIT.txt
20 | [Apache 2.0]: https://www.apache.org/licenses/LICENSE-2.0.txt
21 | [pull request]: https://github.com/racket/algol60/pulls
22 | [issue]: https://github.com/racket/algol60/issues
23 | [development mailing list]: https://lists.racket-lang.org
24 | [LICENSE]: LICENSE
25 | 


--------------------------------------------------------------------------------
/info.rkt:
--------------------------------------------------------------------------------
 1 | #lang info
 2 | 
 3 | (define collection "algol60")
 4 | (define build-deps '("at-exp-lib"
 5 |                      "rackunit-lib"
 6 |                      "racket-doc"
 7 |                      "scribble-doc"
 8 |                      "scribble-lib"
 9 |                      "drracket-tool-lib"
10 |                      "drracket-plugin-lib"))
11 | 
12 | (define drracket-name "Algol 60")
13 | (define drracket-tools '(("tool.rkt")))
14 | (define drracket-tool-names '("Algol 60"))
15 | 
16 | (define scribblings '(("algol60.scrbl" () (experimental 40))))
17 | (define deps '("base"
18 |                "compatibility-lib"
19 |                "drracket-plugin-lib"
20 |                "errortrace-lib"
21 |                "gui-lib"
22 |                "parser-tools-lib"
23 |                "string-constants-lib"))
24 | 
25 | (define pkg-desc "An implementation of the Algol60 language")
26 | 
27 | (define pkg-authors '(mflatt robby))
28 | 
29 | (define license
30 |   '(Apache-2.0 OR MIT))
31 | 


--------------------------------------------------------------------------------
/examples/euler.a60:
--------------------------------------------------------------------------------
 1 | #lang algol60
 2 | 
 3 | begin
 4 | 
 5 | procedure euler (fct,sum,eps,tim); value eps,tim; integer tim;
 6 | real procedure fct; real sum,eps;
 7 | comment euler computes the sum of fct(i) for i from zero up to
 8 | infinity by means of a suitably refined euler transformation. The
 9 | summation is stopped as soon as tim times in succession the absolute
10 | value of the terms of the transformed series are found to be less than
11 | eps. Hence, one should provide a function fct with one integer argument,
12 | an upper bound eps, and an integer tim. The output is the sum sum. euler
13 | is particularly efficient in the case of a slowly convergent or
14 | divergent alternating series;
15 | begin integer i,k,n,t; array m[0:15]; real mn,mp,ds;
16 | i:=n:=t:=0; m[0]:=fct(0); sum:=m[0]/2;
17 | nextterm: i:=i+1; mn:=fct(i);
18 |         for k:=0 step 1 until n do
19 |             begin mp:=(mn+m[k])/2; m[k]:=mn;
20 |                 mn:=mp end;
21 |         if (abs(mn)<abs(m[n])) & (n<15) then
22 |             begin ds:=mn/2; n:=n+1; m[n]:=mn end
23 |         else ds:=mn;
24 |         sum:=sum+ds;
25 |         if abs(ds)<eps then t:=t+1 else t:=0;
26 |         if t<tim then goto nextterm
27 | end;
28 | 
29 | procedure inv(v) ; inv := 1.0/((v+1)^2);
30 | 
31 | real result;
32 | euler(inv, result, 0.00005, 10);
33 | printnln(result);
34 | 
35 | end
36 | 


--------------------------------------------------------------------------------
/lang/reader.rkt:
--------------------------------------------------------------------------------
 1 | #lang s-exp syntax/module-reader
 2 | algol60/lang/algol60
 3 | 
 4 | #:read algol60-read
 5 | #:read-syntax algol60-read-syntax
 6 | #:info algol60-get-info
 7 | #:whole-body-readers? #t
 8 | 
 9 | 
10 | (require "../parse.rkt"
11 |          ;; Parses to generate an AST. Identifiers in the AST
12 |          ;; are represented as syntax objects with source location.
13 | 
14 |          "../simplify.rkt"
15 |          ;; Desugars the AST, transforming `for' to `if'+`goto',
16 |          ;; and flattening `if' statements so they are always
17 |          ;; of the for `if <exp> then goto <label> else goto <label>'
18 | 
19 |          "../compile.rkt"
20 |          ;; Compiles a simplified AST to Scheme.
21 | 
22 |          racket/file
23 |          syntax/strip-context)
24 | 
25 | 
26 | (define (algol60-read in)
27 |   (map syntax->datum (algol60-read-syntax #f in)))
28 | 
29 | 
30 | (define (algol60-read-syntax src in)
31 |   (define parsed (parse-a60-port in src))
32 |   (define simplified (simplify parsed #'here))
33 |   (define compiled (compile-simplified simplified #'here #:module-exports? #t))
34 |   (define stripped (strip-context compiled))
35 | 
36 |   (list stripped))
37 | 
38 | 
39 | 
40 | ;; Extension: cooperate with DrRacket and tell it to use the default,
41 | ;; textual lexer and color scheme when editing algol programs.
42 | (define (algol60-get-info key default default-filter)
43 |   (case key
44 |     [(color-lexer)
45 |      (dynamic-require 'syntax-color/default-lexer
46 |                       'default-lexer)]
47 |     [else
48 |      (default-filter key default)]))
49 | 


--------------------------------------------------------------------------------
/algol60.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket
 2 | 
 3 | ;; Compiles a simplified AST to Scheme.
 4 | (require "runtime.rkt" 
 5 |          "prims.rkt"
 6 |          
 7 |          (for-syntax "parse.rkt"
 8 |                      #|Parses to generate an AST. Identifiers in the AST
 9 |                      ;; are represented as syntax objects with source location.|#
10 |                      
11 |                      "simplify.rkt"
12 |                      #|Desugars the AST, transforming `for' to `if'+`goto',
13 |                      and flattening `if' statements so they are always
14 |                      of the for `if <exp> then goto <label> else goto <label>' |#
15 |                      
16 |                      "compile.rkt" 
17 |                      racket/path))
18 | 
19 | (provide include-algol literal-algol)
20 | 
21 | #| By using #'here for the context of identifiers
22 | introduced by compilation, the identifiers can
23 | refer to runtime functions and primitives, as
24 | well as racket:|#
25 | 
26 | (define-syntax (include-algol stx)
27 |   (syntax-case stx ()
28 |     [(_ str)
29 |      (string? (syntax-e (syntax str)))
30 |      
31 |      (compile-simplified
32 |       (simplify 
33 |        (parse-a60-file 
34 |         (normalize-path (syntax-e (syntax str))
35 |                         (or
36 |                          (current-load-relative-directory)
37 |                          (current-directory))))
38 |        #'here)
39 |       #'here)]))
40 | 
41 | (define-syntax (literal-algol stx)
42 |   (syntax-case stx ()
43 |     [(_ strs ...)
44 |      (andmap (λ (x) (string? (syntax-e x))) 
45 |              (syntax->list (syntax (strs ...))))
46 |      
47 |      (compile-simplified
48 |       (simplify 
49 |        (parse-a60-port
50 |         (open-input-string 
51 |          (apply 
52 |           string-append
53 |           (map syntax-e (syntax->list #'(strs ...)))))
54 |         (syntax-source stx))
55 |        #'here)
56 |       #'here)]))
57 | 


--------------------------------------------------------------------------------
/tests/syncheck-test.rkt:
--------------------------------------------------------------------------------
 1 | #lang racket/base
 2 | 
 3 | (require drracket/check-syntax
 4 |          racket/runtime-path
 5 |          syntax/modread
 6 |          racket/match
 7 |          racket/set
 8 |          rackunit)
 9 | (define-runtime-path made-up-example-file.rkt "made-up-example-file.rkt")
10 | 
11 | (define the-program
12 |   (string-append
13 |    "#lang algol60\n"
14 |    "begin\n"
15 |    "  integer procedure f(theargument);\n"
16 |    "    integer theargument;\n"
17 |    "  printnln(theargument);\n"
18 |    "end\n"))
19 | 
20 | (define theargument-positions
21 |   (regexp-match-positions* #rx"theargument" the-program))
22 | 
23 | (define directives
24 |   (let ([p (open-input-string the-program)])
25 |     (port-count-lines! p)
26 |     (parameterize ([current-namespace (make-base-namespace)])
27 |       (with-module-reading-parameterization
28 |        (λ ()
29 |          (show-content
30 |           (read-syntax
31 |            made-up-example-file.rkt
32 |            p)))))))
33 | 
34 | (define binding-arrow-directives
35 |   (set-remove
36 |    (for/set ([directive (in-list directives)])
37 |      (match directive
38 |        [`#(syncheck:add-arrow/name-dup/pxpy
39 |            ,start-left ,start-right
40 |            ,_ ,_
41 |            ,end-left ,end-right
42 |            ,_ ...)
43 |         (list (cons start-left start-right)
44 |               (cons end-left end-right))]
45 |        [_ #f]))
46 |    #f))
47 | 
48 | 
49 | ;; make sure there is a link from the argument to the declaration of its type
50 | (check-true (set-member? binding-arrow-directives
51 |                          (list (list-ref theargument-positions 0)
52 |                                (list-ref theargument-positions 1))))
53 | 
54 | ;; make sure there is a link from the argument to the use of the argument in the body
55 | (check-true (set-member? binding-arrow-directives
56 |                          (list (list-ref theargument-positions 0)
57 |                                (list-ref theargument-positions 2))))
58 | 


--------------------------------------------------------------------------------
/examples/primes.a60:
--------------------------------------------------------------------------------
 1 | #lang algol60
 2 | 
 3 | begin
 4 |         comment
 5 |           -- From the NASE A60 distribution --
 6 |                 calculation of the prime numbers between 2 and 200
 7 |         ;
 8 | 
 9 |         integer NN;
10 | 
11 |         NN := 200;
12 | 
13 |         begin
14 |                 comment first algorithm (check division in a loop) ;
15 | 
16 |                 Boolean procedure isprime (n);
17 |                 value n;
18 |                 integer n;
19 |                 begin
20 |                         Boolean procedure even (n);
21 |                         value n; integer n;
22 |                                 even := entier (n / 2) * 2 = n;
23 |                         integer i;
24 | 
25 |                         isprime := false;
26 |                         if even (n) & n != 2 then
27 |                                 goto ret;
28 | 
29 |                         for i := 3 step 2 until n div 2 do
30 |                                 if entier (n / i) * i = n then
31 |                                         goto ret;
32 |                         isprime := true;
33 |                     ret:
34 | 
35 |                 end;
36 | 
37 |                 integer i;
38 | 
39 |                 printsln (`first:');
40 | 
41 |                 for i := 2 step 1 until NN do
42 |                         if isprime (i) then
43 |                                 printnln (i);
44 |                 printsln (`done.')
45 |         end;
46 | 
47 |         begin
48 |                 comment second algorithm (sieve) ;
49 | 
50 | 
51 |                 Boolean array arr [2 : NN];
52 |                 integer i, j;
53 | 
54 |                 printsln (`second:');
55 | 
56 |                 for i := 2 step 1 until NN do
57 |                         arr [i] := true;
58 | 
59 |                 for i := 2 step 1 until NN div 2 do
60 |                         for j := 2 * i step i until NN do
61 |                                 arr [j] := false;
62 | 
63 |                 for i := 2 step 1 until NN do
64 |                         if arr [i] then
65 |                                 printnln (i);
66 |                 printsln (`done.')
67 | 
68 |         end
69 | end
70 | 


--------------------------------------------------------------------------------
/tests/test.rkt:
--------------------------------------------------------------------------------
 1 | #lang at-exp racket/base
 2 | (require algol60/algol60
 3 |          rackunit
 4 |          racket/runtime-path
 5 |          (for-syntax racket/base))
 6 | 
 7 | (define-syntax (capture-output stx)
 8 |   (syntax-case stx ()
 9 |     [(_ exp)
10 |      (parameterize ([error-print-source-location #f])
11 |        (with-handlers ((exn:fail?
12 |                         (λ (exn)
13 |                           #`(list 'expand
14 |                                   #,(exn-message exn)))))
15 |          (define expanded (local-expand #'exp 'expression #f))
16 |          #`(let ([op (open-output-string)]
17 |                  [ep (open-output-string)])
18 |              (let/ec k
19 |                (parameterize ([current-output-port op]
20 |                               [current-error-port ep]
21 |                               [error-escape-handler (λ () (k (void)))])
22 |                  #,expanded))
23 |              (list 'run
24 |                    (get-output-string op)
25 |                    (get-output-string ep)))))]))
26 | 
27 | (check-equal?
28 |  (capture-output
29 |   @literal-algol{
30 |     begin
31 |       printsln (`hello world')
32 |     end
33 |   })
34 |  '(run "hello world\n" ""))
35 | 
36 | (check-pred
37 |  (λ (x) (and (eq? (list-ref x 0) 'expand)
38 |              (regexp-match #rx"parse error near BEGIN"
39 |                            (list-ref x 1))))
40 |  (capture-output
41 |   @literal-algol{
42 |     begin
43 |   }))
44 | 
45 | 
46 | (check-pred
47 |  (λ (x) (and (eq? (list-ref x 0) 'expand)
48 |              (regexp-match #rx"parse error near PROCEDURE"
49 |                            (list-ref x 1))))
50 |  (capture-output
51 |   @literal-algol{
52 |     procedure Absmax(a) Size:(n, m) Result:(y) Subscripts:(i, k);
53 |        value n, m; array a; integer n, m, i, k; real y;
54 |     begin integer p, q;
55 |        y := 0; i := k := 1;
56 |        for p:=1 step 1 until n do
57 |        for q:=1 step 1 until m do
58 |            if abs(a[p, q]) > y then
59 |                begin y := abs(a[p, q]);
60 |                i := p; k := q
61 |                end
62 |     end Absmax
63 |   }))
64 | 
65 | (define-runtime-path export.rkt "export.rkt")
66 | (check-equal? ((dynamic-require export.rkt 'f) 2) 1/2)
67 | (check-equal? (object-name (dynamic-require export.rkt 'f)) 'f)
68 | 


--------------------------------------------------------------------------------
/prims.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (provide != ! & \|
  3 |          ==> ==
  4 |          sign entier
  5 |          
  6 |          a60:sin
  7 |          a60:cos
  8 |          a60:arctan
  9 |          a60:sqrt
 10 |          a60:abs
 11 |          a60:ln
 12 |          a60:exp
 13 |          
 14 |          prints printn
 15 |          printsln printnln)
 16 | 
 17 | (define (!= a b)
 18 |   (not (= a b)))
 19 | 
 20 | (define (! a)
 21 |   (unless (boolean? a)
 22 |     (raise-type-error '! "boolean" a))
 23 |   (not a))
 24 | 
 25 | (define (& a b)
 26 |   (unless (boolean? a)
 27 |     (raise-type-error '& "boolean" 0 a b))
 28 |   (unless (boolean? b)
 29 |     (raise-type-error '& "boolean" 1 a b))
 30 |   (and a b))
 31 | 
 32 | (define (\| a b)
 33 |   (unless (boolean? a)
 34 |     (raise-type-error '\| "boolean" 0 a b))
 35 |   (unless (boolean? b)
 36 |     (raise-type-error '\| "boolean" 1 a b))
 37 |   (or a b))
 38 | 
 39 | (define (==> a b)
 40 |   (unless (boolean? a)
 41 |     (raise-type-error '=> "boolean" 0 a b))
 42 |   (unless (boolean? b)
 43 |     (raise-type-error '=> "boolean" 1 a b))
 44 |   (or (not a) b))
 45 | 
 46 | (define (== a b)
 47 |   (unless (boolean? a)
 48 |     (raise-type-error '== "boolean" 0 a b))
 49 |   (unless (boolean? b)
 50 |     (raise-type-error '== "boolean" 1 a b))
 51 |   (eq? a b))
 52 | 
 53 | (define (get-number who v)
 54 |   (let ([v (v)])
 55 |     (unless (number? v)
 56 |       (raise-type-error who "number" v))
 57 |     v))
 58 | 
 59 | (define (get-string who v)
 60 |   (let ([v (v)])
 61 |     (unless (string? v)
 62 |       (raise-type-error who "string" v))
 63 |     v))
 64 | 
 65 | (define (sign k v)
 66 |   (k (let ([v (get-number 'sign v)])
 67 |        (cond
 68 |          [(< v 0) -1]
 69 |          [(> v 0) 1]
 70 |          [else 0]))))
 71 | 
 72 | (define (entier k v)
 73 |   (k (inexact->exact (floor (get-number 'entier v)))))
 74 | 
 75 | (define (a60:abs k v)
 76 |   (k (abs (get-number 'abs v))))
 77 | 
 78 | (define (a60:sqrt k v)
 79 |   (k (sqrt (get-number 'sqrt v))))
 80 | 
 81 | (define (a60:sin k v)
 82 |   (k (sin (get-number 'sin v))))
 83 | 
 84 | (define (a60:cos k v)
 85 |   (k (cos (get-number 'cos v))))
 86 | 
 87 | (define (a60:exp k v)
 88 |   (k (exp (get-number 'exp v))))
 89 | 
 90 | (define (a60:arctan k v)
 91 |   (k (atan (get-number 'arctan v))))
 92 | 
 93 | (define (a60:ln k v)
 94 |   (k (log (get-number 'ln v))))
 95 | 
 96 | (define (printsln k v)
 97 |   (k (printf "~a\n" (get-string 'printsln v))))
 98 | 
 99 | (define (printnln k v)
100 |   (k (printf "~a\n" (get-number 'printnln v))))
101 | 
102 | (define (prints k v)
103 |   (k (printf "~a" (get-string 'prints v))))
104 | 
105 | (define (printn k v)
106 |   (k (printf "~a" (get-number 'printn v))))
107 | 


--------------------------------------------------------------------------------
/algol60.scrbl:
--------------------------------------------------------------------------------
 1 | #lang scribble/doc
 2 | @(require scribble/manual
 3 |           (for-label algol60/algol60))
 4 | 
 5 | @title{Algol 60}
 6 | 
 7 | @section{Implementation}
 8 | 
 9 | The ``Algol 60'' language for DrRacket implements the language defined
10 | by the ``Revised Report on the Algorithmic Language Algol 60,'' edited
11 | by Peter Naur.
12 | 
13 | @section{Including Algol 60 Programs}
14 | 
15 | Although Algol 60 is mainly provided as a DrRacket language,
16 | @racket[include-algol] supports limited use of Algol 60 programs in
17 | larger programs.
18 | 
19 | @defmodule[algol60/algol60]
20 | 
21 | @defform[(include-algol path-string)]{
22 | 
23 | Includes the Algol 60 program indicated by @racket[path-string] as an
24 | expression in a Racket program. The included Algol 60 program is
25 | closed (i.e., it doesn't see any bindings in the included context),
26 | and the result is always @|void-const|.}
27 | 
28 | 
29 | @defform[(literal-algol string ...)]{
30 | 
31 | Evaluates the Algol 60 program indicated by the literal @racket[string]s
32 | as an expression in a Racket program. The Algol 60 program is
33 | closed (i.e., it doesn't see any bindings in the included context),
34 | and the result is always @|void-const|.
35 | 
36 | This is generally useful when combined with the @racketmodname[at-exp] reader,
37 | e.g.,
38 | @codeblock|{
39 | #lang at-exp racket
40 | @literal-algol{
41 |   begin
42 |     printsln (`hello world')
43 |   end
44 | }
45 | }|
46 | }
47 | 
48 | @section{Language}
49 | 
50 | The DrRacket and @racket[include-algol] implementation departs from
51 | the Algol 60 specification in the following minor ways:
52 | 
53 | @(itemize (item "Strings are not permitted to contain nested quotes.")
54 |           (item "Identifiers cannot contain whitespace.")
55 |           (item "Argument separators are constrained to be identifiers (i.e., they
56 |     cannot be keywords, and they cannot consist of multiple
57 |     identifiers separated by whitespace.)")
58 |           (item "Numbers containing exponents (using the ``10'' subscript) are not
59 |     supported."))
60 | 
61 | Identifiers and keywords are case-sensitive. The boldface/underlined
62 | keywords of the report are represented by the obvious character
63 | sequence, as are most operators. A few operators do not fit into
64 | ASCII, and they are mapped as follows:
65 | 
66 | @(verbatim 
67 | "   times             *
68 |    quotient          div
69 |    exponential       ^  
70 |    less or equal     <= 
71 |    greater or equal  >=
72 |    not equal         !=
73 |    equivalence       ==
74 |    implication       =>
75 |    and               &
76 |    or                |
77 |    negation          !")
78 | 
79 | In addition to the standard functions, the following output functions
80 | are supported:
81 | 
82 | @(verbatim
83 | "   prints(E)    prints the string E
84 |    printsln(E)  prints the string E followed by a newline
85 |    printn(E)    prints the number E
86 |    printnln(E)  prints the number E followed by a newline")
87 | 
88 | A prompt in DrRacket's interactions area accepts whole programs only
89 | for the Algol 60 language.
90 | 
91 | 


--------------------------------------------------------------------------------
/examples/nqueen.a60:
--------------------------------------------------------------------------------
  1 | #lang algol60
  2 | 
  3 | begin
  4 |         comment
  5 |           -- From the NASE A60 distribution --
  6 |                 Find a solution for the `N queen problem.
  7 |                 (got the algorithm from a Modula program from
  8 |                  Martin Neitzel).
  9 |         ;
 10 | 
 11 |         integer N, MAXN;
 12 | 
 13 |         MAXN := 9;              comment maximum size;
 14 |         N := 2;                 comment current size;
 15 | 
 16 | tryNextN:
 17 | 
 18 |         begin
 19 | 
 20 |         integer array column [1 : N];
 21 |         Boolean array empcol [1 : N];
 22 |         Boolean array empup [-N+1 : N-1];
 23 |         Boolean array empdo [2 : 2*N];
 24 |         integer i;
 25 | 
 26 |         procedure print;
 27 |         comment
 28 |                 print the current solution in a chessboard alike
 29 |                 picture ;
 30 |         begin
 31 |                 integer i, j;
 32 | 
 33 |                 procedure outframe;
 34 |                 begin
 35 |                         integer i;
 36 | 
 37 |                         for i := 1 step 1 until N do
 38 |                                 prints (`+---');
 39 |                         printsln (`+')
 40 |                 end;
 41 | 
 42 |                 for j := 1 step 1 until N do begin
 43 |                         outframe;
 44 |                         prints (`|');
 45 |                         for i := 1 step 1 until N do begin
 46 |                                 if N + 1 - j = column [i] then
 47 |                                         prints (` Q |')
 48 |                                 else
 49 |                                         prints (`   |')
 50 |                         end;
 51 |                         printsln (`')
 52 |                 end;
 53 |                 outframe;
 54 |         end;
 55 | 
 56 | 
 57 |         procedure set (x);
 58 |         value x;
 59 |         integer x;
 60 |         begin
 61 |                 integer y;
 62 | 
 63 |                 for y := 1 step 1 until N do
 64 |                 begin
 65 |                         if empcol [ y ] & empup [ x-y ] 
 66 |                                         & empdo [ x+y ] then
 67 |                         begin
 68 |                                 column [ y ] := x ;
 69 |                                 empcol [ y ] := false ;
 70 |                                 empup [ x-y ] := false ;
 71 |                                 empdo [ x+y ] := false ;
 72 |                                 if x = N then
 73 |                                         goto gotone
 74 |                                 else
 75 |                                         set ( x + 1 ) ;
 76 |                                 empdo [ x+y ] := true ;
 77 |                                 empup [ x-y ] := true ;
 78 |                                 empcol [ y ] := true ;
 79 |                                 column [ y ] := 0
 80 |                         end
 81 |                 end
 82 |         end;
 83 | 
 84 |         comment
 85 |                 main program start
 86 |         ;
 87 | 
 88 |         prints (`looking onto a ');
 89 |         printn (N);
 90 |         prints (` x ');
 91 |         printn (N);
 92 |         printsln (` chessboard...');
 93 | 
 94 |         for i := 1 step 1 until N do
 95 |         begin
 96 |                  column [ i ] := 0 ;
 97 |                  empcol [ i ] := true
 98 |         end;
 99 | 
100 |         for i := -N+1 step 1 until N-1 do
101 |                  empup [ i ] := true ;
102 | 
103 |         for  i := 2 step 1 until 2*N do
104 |                  empdo [ i ] := true ;
105 | 
106 |         set ( 1 ) ;
107 | 
108 |         printsln (`NO SOLUTION.');
109 |         goto contN;
110 | 
111 | gotone:
112 |         printsln(`SOLVED');
113 |         print;
114 | 
115 | contN:
116 |         if N < MAXN then begin
117 |                 N := N + 1;
118 |                 goto tryNextN
119 |         end;
120 | 
121 |         printsln (`done.')
122 | 
123 |         end
124 | end
125 | 


--------------------------------------------------------------------------------
/runtime.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require racket/undefined)
  3 | (provide (struct-out a60:array)
  4 |          (struct-out a60:switch)
  5 |          undefined
  6 |          check-boolean
  7 |          goto
  8 |          get-value
  9 |          set-target!
 10 |          make-array
 11 |          array-ref
 12 |          array-set!
 13 |          make-switch
 14 |          switch-ref
 15 |          coerce)
 16 | 
 17 | (define-struct a60:array (vec dimens))
 18 | (define-struct a60:switch (choices))
 19 | 
 20 | (define (check-boolean b) b)
 21 | (define (goto f) (f))
 22 | (define (get-value v) (v))
 23 | (define (set-target! t name v)
 24 |   (unless (procedure-arity-includes? t 1)
 25 |     (error 'assignment "formal-argument variable ~a is assigned, but actual argument was not assignable"
 26 |            name))
 27 |   (t v))
 28 | 
 29 | (define (bad what v)
 30 |   (error '|bad value| "expected a ~a, got ~e" what v))
 31 | (define (coerce type v)
 32 |   (cond
 33 |     [(eq? type 'integer) 
 34 |      (if (number? v)
 35 |          (inexact->exact (floor v))
 36 |          (bad 'number v))]
 37 |     [(eq? type 'real) 
 38 |      (if (number? v)
 39 |          (exact->inexact v)
 40 |          (bad 'number v))]
 41 |     [(eq? type 'boolean) 
 42 |      (if (boolean? v)
 43 |          v
 44 |          (bad 'boolean v))]
 45 |     [else v]))
 46 | 
 47 | (define (make-array . dimens)
 48 |   (make-a60:array
 49 |    ((let loop ([dimens dimens])
 50 |       (if (null? dimens)
 51 |           (lambda () undefined)
 52 |           (let ([start (car dimens)]
 53 |                 [end (cadr dimens)])
 54 |             (let ([build (loop (cddr dimens))])
 55 |               (lambda () 
 56 |                 (let ([len (add1 (- end start))])
 57 |                   (let ([v (make-vector len)])
 58 |                     (let loop ([len len])
 59 |                       (unless (zero? len)
 60 |                         (vector-set! v (sub1 len) (build))
 61 |                         (loop (sub1 len))))
 62 |                     v))))))))
 63 |    dimens))
 64 | 
 65 | (define (check-array a is who)
 66 |   (unless (a60:array? a)
 67 |     (error who "not an array: ~e" a))
 68 |   (unless (= (length is) (/ (length (a60:array-dimens a)) 2))
 69 |     (error who "array dimension ~a doesn't match the number of provided indices ~a"
 70 |            (length is) (/ (length (a60:array-dimens a)) 2))))
 71 | 
 72 | (define (check-index who dimens indices)
 73 |   (unless (and (number? (car indices))
 74 |                (exact? (car indices))
 75 |                (integer? (car indices)))
 76 |     (error who "index is not an integer: ~e"
 77 |            (car indices)))
 78 |   (unless (<= (car dimens) (car indices) (cadr dimens))
 79 |     (error who "index ~a out of range ~a:~a"
 80 |            (car indices) (car dimens) (cadr dimens))))
 81 | 
 82 | (define (array-ref a . indices)
 83 |   (check-array a indices 'array-reference)
 84 |   (let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
 85 |     (check-index 'array-reference dimens indices)
 86 |     (let ([i (vector-ref v (- (car indices) (car dimens)))])
 87 |       (if (null? (cdr indices))
 88 |           i
 89 |           (loop i (cdr indices) (cddr dimens))))))
 90 | 
 91 | (define (array-set! a val . indices)
 92 |   (check-array a indices 'array-assignment)
 93 |   (let loop ([v (a60:array-vec a)][indices indices][dimens (a60:array-dimens a)])
 94 |     (check-index 'array-assignment dimens indices)
 95 |     (if (null? (cdr indices))
 96 |         (vector-set! v (- (car indices) (car dimens)) val)
 97 |         (loop (vector-ref v (- (car indices) (car dimens))) (cdr indices) (cddr dimens)))))
 98 | 
 99 | (define (make-switch . choices)
100 |   (make-a60:switch (list->vector choices)))
101 | (define (switch-ref sw index)
102 |   (unless (and (number? index)
103 |                (integer? index)
104 |                (exact? index)
105 |                (<= 1 index (vector-length (a60:switch-choices sw))))
106 |     (error "bad switch index: " index))
107 |   ((vector-ref (a60:switch-choices sw) (sub1 index))))
108 | 


--------------------------------------------------------------------------------
/tool.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket/base
  2 | (require drracket/tool
  3 |          racket/gui
  4 |          racket/unit
  5 |          racket/class
  6 |          "parse.rkt"
  7 |          "simplify.rkt"
  8 |          "compile.rkt"
  9 |          compiler/embed
 10 |          string-constants
 11 |          errortrace/errortrace-lib)
 12 | 
 13 | (provide tool@)
 14 | 
 15 | (define base-importing-stx (dynamic-require 'algol60/base
 16 |                                             'base-importing-stx))
 17 | 
 18 | (define-unit tool@
 19 |     (import drracket:tool^)
 20 |     (export drracket:tool-exports^)
 21 |     
 22 |     (define (phase1) (void))
 23 |     (define (phase2)
 24 |       (drracket:language-configuration:add-language
 25 |        (make-object (override-mrflow-methods
 26 |                      ((drracket:language:get-default-mixin) 
 27 |                       lang%)))))
 28 |     
 29 |     (define (override-mrflow-methods %)
 30 |       (if (method-in-interface? 'render-value-set (class->interface %))
 31 |           (class %
 32 |             (inherit [super-render-value-set render-value-set]
 33 |                      [super-get-mrflow-primitives-filename get-mrflow-primitives-filename])
 34 |             (define/override (render-value-set . x)
 35 |               ;; needs to be filled in!
 36 |               (super-render-value-set . x))
 37 |             (define/override (get-mrflow-primitives-filename)
 38 |               (build-path (collection-path "mrflow")
 39 |                           "primitives"
 40 |                           "algol60.rkt"))
 41 |             (super-instantiate ()))
 42 |           %))
 43 |     
 44 |     (define lang%
 45 |       (class* object% (drracket:language:language<%>)
 46 |         (define/public (front-end/finished-complete-program settings) (void))
 47 |         (define/public (extra-repl-information settings port) (void))
 48 |         (define/public (get-reader-module) #f)
 49 |         (define/public (get-metadata a b) #f)
 50 |         (define/public (metadata->settings m) #f)
 51 |         (define/public (get-metadata-lines) #f)
 52 |         
 53 |         (define/public (capability-value s) (drracket:language:get-capability-default s))
 54 |         (define/public (first-opened) (void))
 55 |         (define/public (config-panel parent)
 56 |           (case-lambda
 57 |             [() null]
 58 |             [(x) (void)]))
 59 |         (define/public (get-comment-character) (values "'COMMENT'" #\*))
 60 |         (define/public (default-settings) null)
 61 |         (define/public (default-settings? x) #t)
 62 |         (define/private (front-end port settings)
 63 |           (let ([name (object-name port)])
 64 |             (lambda ()
 65 |               (if (eof-object? (peek-char port))
 66 |                   eof
 67 |                   (compile-simplified 
 68 |                    (simplify (parse-a60-port port name) base-importing-stx) 
 69 |                    base-importing-stx)))))
 70 |         (define/public (front-end/complete-program port settings) (front-end port settings))
 71 |         (define/public (front-end/interaction port settings) (front-end port settings))
 72 |         (define/public (get-style-delta) #f)
 73 |         (define/public (get-language-position)
 74 |           (list (string-constant experimental-languages)
 75 |                 "Algol 60"))
 76 |         (define/public (get-language-name) "Algol 60")
 77 |         (define/public (get-language-url) #f)
 78 |         (define/public (get-language-numbers) (list 1000 10))
 79 |         (define/public (get-teachpack-names) null)
 80 |         (define/public (marshall-settings x) x)
 81 |         (define/public (on-execute settings run-in-user-thread)
 82 |           (dynamic-require 'algol60/base #f)
 83 |           (let ([path ((current-module-name-resolver) 'algol60/base #f #f)]
 84 |                 [n (current-namespace)])
 85 |             (run-in-user-thread
 86 |              (lambda ()
 87 |                (error-display-handler 
 88 |                 (drracket:debug:make-debug-error-display-handler (error-display-handler)))
 89 |                (current-compile (make-errortrace-compile-handler))
 90 |                (with-handlers ([void (lambda (x)
 91 |                                        (printf "~a\n"
 92 |                                                (exn-message x)))])
 93 |                  (namespace-attach-module n path)
 94 |                  (namespace-require path))))))
 95 |         (define/public (render-value value settings port) (write value port))
 96 |         (define/public (render-value/format value settings port width) (write value port))
 97 |         (define/public (unmarshall-settings x) x)
 98 |         (define/public (create-executable settings parent src-file)
 99 |           (let ([dst-file (drracket:language:put-executable
100 |                            parent src-file #f #f
101 |                            (string-constant save-a-mzscheme-stand-alone-executable))])
102 |             (when dst-file
103 |               (let ([code (compile-simplified (simplify (parse-a60-file src-file)
104 |                                                         base-importing-stx)
105 |                                               base-importing-stx)])
106 |                 (make-embedding-executable dst-file
107 |                                            #f #f
108 |                                            '((#f algol60/base))
109 |                                            null
110 |                                            (compile
111 |                                             `(module m algol60/base
112 |                                                ,code))
113 |                                            (list "-mvqe" "(require m)"))))))
114 |         (define/public (get-one-line-summary) "Of historic interest")
115 |         
116 |         (super-instantiate ()))))
117 | 


--------------------------------------------------------------------------------
/simplify.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require "parse.rkt"
  3 |          (except-in racket/match ==))
  4 | 
  5 | (provide simplify)
  6 | 
  7 | ;; flatten/label-block : list-of-decl list-of-stmt -> block-stmt
  8 | ;; Desugars `for', converts `if' so that it's always of the form
  9 | ;; `if <test> then goto <label> else goto <label>', flattens
 10 | ;; compound statements into the enclosing block, and gives every
 11 | ;; statement exactly one label. The result usually has lots of
 12 | ;; "dummy" statements that could easily be eliminated by merging
 13 | ;; labels.
 14 | (define (flatten/label-block decls statements ->stx)
 15 |   (define extra-decls null)
 16 |   (define new-statements
 17 |     (let loop ([l statements])
 18 |       (if (null? l)
 19 |           null
 20 |           (match (car l)
 21 |             [(a60:block decls statements)
 22 |              (cons (cons (gensym 'block) (flatten/label-block decls statements ->stx))
 23 |                    (loop (cdr l)))]
 24 |             [(a60:compound statements)
 25 |              (loop (append statements (cdr l)))]
 26 |             [(a60:branch test then else)
 27 |              (if (and (a60:goto? then) (a60:goto? else))
 28 |                  (cons (cons (gensym 'branch) (car l))
 29 |                        (loop (cdr l)))
 30 |                  (let ([then-label (gensym 'then)]
 31 |                        [else-label (gensym 'else)]
 32 |                        [cont-label (gensym 'if-cont)])
 33 |                    (loop
 34 |                     (list*
 35 |                      (make-a60:branch test (make-a60:goto then-label) (make-a60:goto else-label))
 36 |                      (make-a60:label then-label then)
 37 |                      (make-a60:goto cont-label)
 38 |                      (make-a60:label else-label else)
 39 |                      (make-a60:label cont-label (make-a60:dummy))
 40 |                      (cdr l)))))]
 41 |             [(a60:for variable val-exprs body)
 42 |              (let ([body-label (gensym 'for-body)]
 43 |                    [cont-label (gensym 'for-cont)])
 44 |                (letrec ([make-init+test+increment+loop
 45 |                          (lambda (value)
 46 |                            (match value
 47 |                              [(a60:for-number value)
 48 |                               (values (make-a60:assign (list variable) (make-a60:binary 'num 'num
 49 |                                                                                         (->stx '+) 
 50 |                                                                                         (->stx '0)
 51 |                                                                                         value)) ; +0 => number
 52 |                                       (->stx #t)
 53 |                                       (make-a60:dummy)
 54 |                                       #f)]
 55 |                              [(a60:for-step start step end)
 56 |                               (values (make-a60:assign (list variable) start)
 57 |                                       (make-a60:binary 'bool 'num
 58 |                                                        (->stx '<=)
 59 |                                                        (make-a60:binary 'num 'num
 60 |                                                                         (->stx '*)
 61 |                                                                         (make-a60:binary 'num 'num (->stx '-) variable end)
 62 |                                                                         (make-a60:app (->stx 'sign) (list step)))
 63 |                                                        (->stx '0))
 64 |                                       (make-a60:assign (list variable) (make-a60:binary 'num 'num (->stx '+) variable step))
 65 |                                       #t)]
 66 |                              [(a60:for-while value test)
 67 |                               (values (make-a60:assign (list variable) value)
 68 |                                       test
 69 |                                       (make-a60:assign (list variable) value)
 70 |                                       #t)]))])
 71 |                  (if (= 1 (length val-exprs))
 72 |                      (let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
 73 |                        (loop (list*
 74 |                               init
 75 |                               (make-a60:label body-label (make-a60:dummy))
 76 |                               (make-a60:branch test 
 77 |                                                (make-a60:compound
 78 |                                                 (list
 79 |                                                  body
 80 |                                                  inc
 81 |                                                  (if loop?
 82 |                                                      (make-a60:goto body-label)
 83 |                                                      (make-a60:dummy))))
 84 |                                                (make-a60:dummy))
 85 |                               (cdr l))))
 86 |                      (let* ([stage-name (datum->syntax #f (gensym 'stage-number))]
 87 |                             [switch-name (datum->syntax #f (gensym 'stage-switch))]
 88 |                             [end-switch-name (datum->syntax #f (gensym 'stage-switch))]
 89 |                             [stage-var (make-a60:variable stage-name null)]
 90 |                             [start-labels (map (lambda (x) (gensym 'stage)) (append val-exprs (list 'extra)))]
 91 |                             [end-labels (map (lambda (x) (gensym 'stage)) val-exprs)])
 92 |                        (set! extra-decls (list* stage-name 
 93 |                                                 (cons switch-name start-labels)
 94 |                                                 (cons end-switch-name end-labels)
 95 |                                                 extra-decls))
 96 |                        (loop
 97 |                         (append
 98 |                          (list (make-a60:assign (list stage-var) (->stx '0)))
 99 |                          (let loop ([start-labels start-labels][end-labels end-labels][val-exprs val-exprs])
100 |                            (if (null? val-exprs)
101 |                                (list (make-a60:label (car start-labels) (make-a60:dummy)))
102 |                                (let-values ([(init test inc loop?) (make-init+test+increment+loop (car val-exprs))])
103 |                                  (list*
104 |                                   (make-a60:label (car start-labels) (make-a60:dummy))
105 |                                   init
106 |                                   (make-a60:branch test 
107 |                                                    (make-a60:goto body-label)
108 |                                                    (make-a60:compound                                                   
109 |                                                     (list
110 |                                                      (make-a60:assign (list stage-var) (make-a60:binary 'num 'num
111 |                                                                                                         (->stx '+)
112 |                                                                                                         (->stx '1)
113 |                                                                                                         stage-var))
114 |                                                      (make-a60:goto (make-a60:subscript switch-name stage-var)))))
115 |                                   (make-a60:label (car end-labels) (make-a60:dummy))
116 |                                   inc
117 |                                   (if loop?
118 |                                       (make-a60:goto (car start-labels))
119 |                                       (make-a60:goto (cadr start-labels)))
120 |                                   (loop (cdr start-labels)
121 |                                         (cdr end-labels)
122 |                                         (cdr val-exprs))))))
123 |                          (list 
124 |                           (make-a60:goto cont-label)
125 |                           (make-a60:label body-label (make-a60:dummy))
126 |                           body
127 |                           (make-a60:goto (make-a60:subscript end-switch-name stage-var))
128 |                           (make-a60:label cont-label (make-a60:dummy)))
129 |                          (cdr l)))))))]
130 |             [(a60:label name statement)
131 |              (cons (cons name (make-a60:dummy))
132 |                    (loop (cons statement (cdr l))))]
133 |             [else
134 |              (cons (cons (gensym 'other) (car l))
135 |                    (loop (cdr l)))]))))
136 |   (make-a60:block
137 |    (append
138 |     (map (lambda (decl)
139 |            (match decl
140 |              [(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
141 |               (make-a60:proc-decl result-type var arg-vars by-value-vars arg-specs
142 |                                   (simplify-statement body ->stx))]
143 |              [else decl]))
144 |          decls)
145 |     (map (lambda (extra)
146 |            (if (identifier? extra)
147 |                (make-a60:type-decl (->stx 'integer) (list extra))
148 |                (make-a60:switch-decl (car extra) (map (lambda (x) 
149 |                                                         (make-a60:variable (datum->syntax #f x) null)) 
150 |                                                       (cdr extra)))))
151 |          extra-decls))
152 |    (if (null? new-statements)
153 |        (list (cons (gensym 'other) (make-a60:dummy)))
154 |        new-statements)))
155 | 
156 | (define (simplify stmt ctx)
157 |   (simplify-statement stmt (lambda (x)
158 |                              (datum->syntax
159 |                               ctx
160 |                               x))))
161 | 
162 | (define (simplify-statement stmt ->stx)
163 |   (match stmt
164 |     [(a60:block decls statements)
165 |      (flatten/label-block decls statements ->stx)]
166 |     [(a60:compound statements)
167 |      (flatten/label-block null statements ->stx)]
168 |     [else stmt]))
169 | 


--------------------------------------------------------------------------------
/parse.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require parser-tools/lex
  3 |          (prefix-in : parser-tools/lex-sre)
  4 |          "cfg-parser.rkt"
  5 |          parser-tools/yacc
  6 |          syntax/readerr
  7 |          "prims.rkt")
  8 | 
  9 | (provide parse-a60-file parse-a60-port)
 10 | 
 11 | (define-lex-abbrevs [lex:letter (:or (:/ #\a #\z) (:/ #\A #\Z))]
 12 |   [lex:digit (:/ #\0 #\9)]
 13 |   [lex:whitespace (:or #\newline #\return #\tab #\space #\vtab)]
 14 |   [lex:comment (:: (:* lex:whitespace) "comment" (:* (:~ #\;)) #\;)])
 15 | 
 16 | (define-tokens non-terminals (<logical-value> 
 17 |                               <type> <identifier> 
 18 |                               <unsigned-integer> <unsigned-float> <string>
 19 |                               
 20 |                               GOTO IF THEN ELSE FOR DO STEP UNTIL WHILE
 21 |                               OWN ARRAY STRING PROCEDURE SWITCH LABEL VALUE
 22 |                               BEGIN END
 23 |                               POWER PLUS MINUS TIMES SLASH DIVIDE
 24 |                               LESS LESS-OR-EQUAL EQUAL GREATER-OR-EQUAL GREATER NOT-EQUAL ASSIGN
 25 |                               NEGATE AND OR IMPLIES EQUIV
 26 |                               COMMA COLON SEMICOLON
 27 |                               OPEN CLOSE OPENSQ CLOSESQ
 28 |                               EOF
 29 |                               UNPARSEABLE))
 30 | 
 31 | (define stx-for-original-property (read-syntax #f (open-input-string "original")))
 32 | 
 33 | (define-syntax (token stx)
 34 |   (syntax-case stx ()
 35 |     [(_ name val)
 36 |      (identifier? (syntax name))
 37 |      (let ([name (syntax name)])
 38 |        (with-syntax ([token-name (datum->syntax
 39 |                                   name
 40 |                                   (string->symbol
 41 |                                    (format "token-~a" (syntax-e name))))]
 42 |                      [source-name (datum->syntax name 'source-name)]
 43 |                      [start-pos (datum->syntax name 'start-pos)]
 44 |                      [end-pos (datum->syntax name 'end-pos)])
 45 |          (syntax 
 46 |           (token-name 
 47 |            (datum->syntax #f val
 48 |                                  (list
 49 |                                   source-name
 50 |                                   (position-line start-pos)
 51 |                                   (position-col start-pos)
 52 |                                   (position-offset start-pos)
 53 |                                   (- (position-offset end-pos)
 54 |                                      (position-offset start-pos)))
 55 |                                  stx-for-original-property)))))]))
 56 | (define-syntax (ttoken stx)
 57 |   (syntax-case stx ()
 58 |     [(_ name)
 59 |      (identifier? (syntax name))
 60 |      (syntax (token name 'name))]))
 61 | 
 62 | (define (lex source-name)
 63 |   (lexer
 64 |    [(:+ lex:whitespace) (void)]
 65 |    ["true" (token <logical-value> #t)]
 66 |    ["false" (token <logical-value> #f)]
 67 |    ["real" (token <type> 'real)]
 68 |    ["integer" (token <type> 'integer)]
 69 |    ["Boolean" (token <type> 'boolean)]
 70 |    ["goto" (ttoken GOTO)]
 71 |    ["if" (ttoken IF)]
 72 |    ["then" (ttoken THEN)]
 73 |    ["else" (ttoken ELSE)]
 74 |    ["for" (ttoken FOR)]
 75 |    ["do" (ttoken DO)]
 76 |    ["step" (ttoken STEP)]
 77 |    ["until" (ttoken UNTIL)]
 78 |    ["while" (ttoken WHILE)]
 79 |    ["own" (ttoken OWN)]
 80 |    ["array" (ttoken ARRAY)]
 81 |    ["string" (ttoken STRING)]
 82 |    ["procedure" (ttoken PROCEDURE)]
 83 |    ["switch" (ttoken SWITCH)]
 84 |    ["label" (ttoken LABEL)]
 85 |    ["value" (ttoken VALUE)]
 86 |    [(:: "begin" lex:comment) (ttoken BEGIN)]
 87 |    ["begin" (ttoken BEGIN)]
 88 |    [(:: "end" lex:comment) (ttoken END)]
 89 |    ["end" (ttoken END)]
 90 |    ["^" (token POWER 'expt)]
 91 |    ["+" (token PLUS '+)]
 92 |    ["-" (token MINUS '-)]
 93 |    ["*" (token TIMES '*)]
 94 |    ["/" (token SLASH '/)]
 95 |    ["div" (token DIVIDE 'quotient)]
 96 |    ["<" (token LESS '<)]
 97 |    ["<=" (token LESS-OR-EQUAL '<=)]
 98 |    ["=" (token EQUAL '=)]
 99 |    [">" (token GREATER '>)]
100 |    [">=" (token GREATER-OR-EQUAL '>=)]
101 |    ["!=" (token NOT-EQUAL '!=)]
102 |    ["!" (token NEGATE '!)]
103 |    ["&" (token AND '&)]
104 |    ["|" (token OR '\|)]
105 |    ["=>" (token IMPLIES '==>)]
106 |    ["==" (token EQUIV '==)]
107 |    [":=" (ttoken ASSIGN)]
108 |    ["," (ttoken COMMA)]
109 |    [":" (ttoken COLON)]
110 |    [(:: ";" lex:comment) (ttoken SEMICOLON)]
111 |    [";" (ttoken SEMICOLON)]
112 |    ["(" (ttoken OPEN)]
113 |    [")" (ttoken CLOSE)]
114 |    ["[" (ttoken OPENSQ)]
115 |    ["]" (ttoken CLOSESQ)]
116 |    [(:: lex:letter (:* (:or lex:letter lex:digit))) (token <identifier> (string->symbol lexeme))]
117 |    [(:+ lex:digit) (token <unsigned-integer> (string->number lexeme))]
118 |    [(:or (:: (:+ lex:digit) #\. (:* lex:digit))
119 |          (:: (:* lex:digit) #\. (:+ lex:digit))) (token <unsigned-float> (string->number lexeme))]
120 |    [(:: #\` (:* (:~ #\' #\`)) #\') (let ([s lexeme])
121 |                                      (token <string> (substring s 1 (sub1 (string-length s)))))]
122 |    [(eof) (ttoken EOF)]
123 |    [any-char (token UNPARSEABLE (string->symbol lexeme))]))
124 | 
125 | (define parse
126 |   (cfg-parser
127 |    (tokens non-terminals)
128 |    (start <program>)
129 |    (end EOF)
130 |    (error (lambda (_ name stx start end) 
131 |             (raise-read-error (format "parse error near ~a" name)
132 |                               (syntax-source stx)
133 |                               (syntax-line stx)
134 |                               (syntax-column stx)
135 |                               (syntax-position stx)
136 |                               (syntax-span stx))))
137 |    (suppress)
138 |    (grammar 
139 |     ;; ==================== Expressions ====================
140 |     (<expression> [(<arithmetic-expression>) $1]
141 |                   [(<Boolean-expression>) $1]
142 |                   [(<designational-expression>) $1])
143 |     ;; -------------------- Numbers --------------------
144 |     (<arithmetic-expression> [(<simple-arithmetic-expression>) $1]
145 |                              [(IF <Boolean-expression> 
146 |                                   THEN <simple-arithmetic-expression> 
147 |                                   ELSE <arithmetic-expression>)
148 |                               (make-a60:if $2 $4 $6)])
149 |     (<simple-arithmetic-expression> [(<term>) $1]
150 |                                     [(<adding-operator> <term>) (make-a60:unary 'num 'num $1 $2)]
151 |                                     [(<simple-arithmetic-expression> <adding-operator> <term>) 
152 |                                      (make-a60:binary 'num 'num $2 $1 $3)])
153 |     (<term> [(<factor>) $1]
154 |             [(<term> <multiplying-operator> <factor>) (make-a60:binary 'num 'num $2 $1 $3)])
155 |     (<factor> [(<primary>) $1]
156 |               [(<factor> POWER <primary>) (make-a60:binary 'num 'num $2 $1 $3)])
157 |     (<adding-operator> [(PLUS) $1]
158 |                        [(MINUS) $1])
159 |     (<multiplying-operator> [(TIMES) $1]
160 |                             [(SLASH) $1]
161 |                             [(DIVIDE) $1])
162 |     (<primary> [(<unsigned-integer>) $1]
163 |                [(<unsigned-float>) $1]
164 |                [(<variable>) $1]
165 |                [(<function-designator>) $1]
166 |                [(OPEN <arithmetic-expression> CLOSE) $2])
167 |     ;; -------------------- Booleans --------------------
168 |     (<relational-operator> [(LESS) $1]
169 |                            [(LESS-OR-EQUAL) $1]
170 |                            [(EQUAL) $1]
171 |                            [(GREATER-OR-EQUAL) $1]
172 |                            [(GREATER) $1]
173 |                            [(NOT-EQUAL) $1])
174 |     (<relation> [(<simple-arithmetic-expression> <relational-operator> <simple-arithmetic-expression>)
175 |                  (make-a60:binary 'bool 'num $2 $1 $3)])
176 |     (<Boolean-primary> [(<logical-value>) $1]
177 |                        [(<variable>) $1]
178 |                        [(<function-designator>) $1]
179 |                        [(<relation>) $1]
180 |                        [(OPEN <Boolean-expression> CLOSE) $2])
181 |     (<Boolean-secondary> [(<Boolean-primary>) $1]
182 |                          [(NEGATE <Boolean-primary>) (make-a60:unary 'bool 'bool $1 $2)])
183 |     (<Boolean-factor> [(<Boolean-secondary>) $1]
184 |                       [(<Boolean-factor> AND <Boolean-secondary>) (make-a60:binary 'bool 'bool $2 $1 $3)])
185 |     (<Boolean-term> [(<Boolean-factor>) $1]
186 |                     [(<Boolean-term> OR <Boolean-factor>)  (make-a60:binary 'bool 'bool $2 $1 $3)])
187 |     
188 |     (<implication> [(<Boolean-term>) $1]
189 |                    [(<implication> IMPLIES <Boolean-term>) (make-a60:binary 'bool 'bool $2 $1 $3)])
190 |     (<simple-Boolean> [(<implication>) $1]
191 |                       [(<simple-Boolean> EQUIV <implication>) (make-a60:binary 'bool 'bool $2 $1 $3)])
192 |     (<Boolean-expression> [(<simple-Boolean>) $1]
193 |                           [(IF <Boolean-expression> 
194 |                                THEN <simple-Boolean> 
195 |                                ELSE <Boolean-expression>)
196 |                            (make-a60:if $2 $4 $6)])
197 |     ;; -------------------- Designationals --------------------
198 |     (<label> [(<identifier>) $1]
199 |              [(<unsigned-integer>) $1])
200 |     (<switch-identifier> [(<identifier>) $1])
201 |     (<switch-designator> [(<switch-identifier> OPENSQ <arithmetic-expression> CLOSESQ)
202 |                           (make-a60:subscript $1 $3)])
203 |     (<simple-designational-expression> [(<label>) $1]
204 |                                        [(<switch-designator>) $1]
205 |                                        [(OPEN <designational-expression> CLOSE) $2])
206 |     (<designational-expression> [(<simple-designational-expression>) $1]
207 |                                 [(IF <Boolean-expression> 
208 |                                      THEN <simple-designational-expression> 
209 |                                      ELSE <designational-expression>)
210 |                                  (make-a60:if $2 $4 $6)])
211 |     ;; -------------------- Variables --------------------
212 |     (<subscript-list> [(<arithmetic-expression>) (list $1)]
213 |                       [(<subscript-list> COMMA <arithmetic-expression>) (append $1 (list $3))])
214 |     (<subscripted-variable> [(<identifier> OPENSQ <subscript-list> CLOSESQ) (make-a60:variable $1 $3)])
215 |     (<variable> [(<identifier>) (make-a60:variable $1 null)]
216 |                 [(<subscripted-variable>) $1])
217 |     ;; -------------------- Function calls --------------------
218 |     (<function-designator> [(<identifier> <actual-parameter-part>) (make-a60:app $1 $2)])
219 |     ;; ==================== Statements ====================
220 |     ;;  - - - - - - - - - - non-empty - - - - - - - - - - 
221 |     (<unlabelled-basic-nonempty-statement> [(<assignment-statement>) $1]
222 |                                            [(<go-to-statement>) $1]
223 |                                            [(<procedure-statement>) $1])
224 |     (<basic-nonempty-statement> [(<unlabelled-basic-nonempty-statement>) $1]
225 |                                 [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
226 |     (<unconditional-nonempty-statement> [(<basic-nonempty-statement>) $1]
227 |                                         [(<compound-statement>) $1]
228 |                                         [(<block>) $1])
229 |     (<nonempty-statement> [(<unconditional-nonempty-statement>) $1]
230 |                           [(<conditional-statement>) $1]
231 |                           [(<for-statement>) $1])
232 |     ;;  - - - - - - - - - - possibly empty - - - - - - - - - -          
233 |     (<unlabelled-basic-statement> [(<unlabelled-basic-nonempty-statement>) $1]
234 |                                   [(<dummy-statement>) $1])
235 |     (<basic-statement> [(<unlabelled-basic-statement>) $1]
236 |                        [(<label> COLON <basic-statement>) (make-a60:label $1 $3)])
237 |     (<unconditional-statement> [(<basic-statement>) $1]
238 |                                [(<unconditional-nonempty-statement>) $1])
239 |     (<statement> [(<unconditional-statement>) $1]
240 |                  [(<nonempty-statement>) $1])
241 |     ;; -------------------- block and compound --------------------
242 |     (<compound-tail> [(<statement> END) (list $1)]
243 |                      [(<statement> SEMICOLON <compound-tail>) (cons $1 $3)])
244 |     (<block-head> [(BEGIN <declaration>) (list $2)]
245 |                   [(<block-head> SEMICOLON <declaration>) (append $1 (list $3))])
246 |     (<unlabelled-block> [(<block-head> SEMICOLON <compound-tail>) (make-a60:block $1 $3)])
247 |     (<unlabelled-compound> [(BEGIN <compound-tail>) (make-a60:compound $2)])
248 |     
249 |     (<compound-statement> [(<unlabelled-compound>) $1]
250 |                           [(<label> COLON <compound-statement>) (make-a60:label $1 $3)])
251 |     (<block> [(<unlabelled-block>) $1]
252 |              [(<label> COLON <block>) (make-a60:label $1 $3)])
253 |     ;; -------------------- assignment --------------------
254 |     (<left-part> [(<variable> ASSIGN) $1])
255 |     (<left-part-list> [(<left-part>) (list $1)]
256 |                       [(<left-part-list> <left-part>) (append $1 (list $2))])
257 |     (<assignment-statement> [(<left-part-list> <arithmetic-expression>) (make-a60:assign $1 $2)]
258 |                             [(<left-part-list> <Boolean-expression>) (make-a60:assign $1 $2)])
259 |     ;; -------------------- goto --------------------
260 |     (<go-to-statement> [(GOTO <designational-expression>) (make-a60:goto $2)])
261 |     ;; -------------------- dummy --------------------
262 |     (<dummy-statement> [() (make-a60:compound null)])
263 |     ;; -------------------- conditional --------------------
264 |     (<conditional-statement> [(IF <Boolean-expression> THEN <unconditional-statement>)
265 |                               (make-a60:branch $2 $4 (make-a60:compound null))]
266 |                              [(IF <Boolean-expression> THEN <unconditional-statement> ELSE <statement>)
267 |                               (make-a60:branch $2 $4 $6)]
268 |                              [(IF <Boolean-expression> THEN <for-statement>)
269 |                               (make-a60:branch $2 $4 (make-a60:compound null))]
270 |                              [(<label> COLON <conditional-statement>) (make-a60:label $1 $3)])
271 |     ;; -------------------- for --------------------
272 |     (<for-list-element> [(<arithmetic-expression>) (make-a60:for-number $1)]
273 |                         [(<arithmetic-expression> STEP <arithmetic-expression> UNTIL <arithmetic-expression>)
274 |                          (make-a60:for-step $1 $3 $5)]
275 |                         [(<arithmetic-expression> WHILE <Boolean-expression>) (make-a60:for-while $1 $3)])
276 |     (<for-list> [(<for-list-element>) (list $1)]
277 |                 [(<for-list> COMMA <for-list-element>) (append $1 (list $3))])
278 |     (<for-statement> [(FOR <variable> ASSIGN <for-list> DO <statement>)
279 |                       (make-a60:for $2 $4 $6)]
280 |                      [(<label> COLON <for-statement>) (make-a60:label $1 $3)])
281 |     ;; -------------------- procedure statement --------------------
282 |     (<actual-parameter> [(<string>) $1]
283 |                         [(<expression>) $1]
284 |                         ; [(<identifier>) $1] ; switch, array, or procedure
285 |                         )
286 |     (<parameter-delimiter> [(COMMA) (void)]
287 |                            [(CLOSE <identifier> COLON OPEN) (void)]) ;; <identifier> was <letter-string>!
288 |     (<actual-parameter-list> [(<actual-parameter>) (list $1)]
289 |                              [(<actual-parameter-list> <parameter-delimiter> <actual-parameter>)
290 |                               (append $1 (list $3))])
291 |     (<actual-parameter-part> [() null]
292 |                              [(OPEN <actual-parameter-list> CLOSE) $2])
293 |     (<procedure-statement> [(<identifier> <actual-parameter-part>) (make-a60:call $1 $2)])
294 |     ;; ==================== Declarations ====================
295 |     (<declaration> [(<type-declaration>) $1]
296 |                    [(<array-declaration>) $1]
297 |                    [(<switch-declaration>) $1]
298 |                    [(<procedure-declaration>) $1])
299 |     ;; -------------------- Simple --------------------
300 |     (<type-list> [(<identifier>) (list $1)]
301 |                  [(<identifier> COMMA <type-list>) (cons $1 $3)])
302 |     (<local-or-own-type> [(<type>) $1]
303 |                          [(OWN <type>) (box $2)]) ; box => own
304 |     (<type-declaration> [(<local-or-own-type> <type-list>) (make-a60:type-decl $1 $2)])
305 |     ;; -------------------- Arrays --------------------
306 |     (<bound-pair> [(<arithmetic-expression> COLON <arithmetic-expression>) (cons $1 $3)])
307 |     (<bound-pair-list> [(<bound-pair>) (list $1)]
308 |                        [(<bound-pair-list> COMMA <bound-pair>) (append $1 (list $3))])
309 |     (<array-segment> [(<identifier> OPENSQ <bound-pair-list> CLOSESQ) (list (cons $1 $3))]
310 |                      [(<identifier> COMMA <array-segment>) (cons (cons $1 (cdar $3)) $3)])
311 |     (<array-list> [(<array-segment>) $1]
312 |                   [(<array-list> COMMA <array-segment>) (append $1 $3)])
313 |     (<array-declaration> [(ARRAY <array-list>) (make-a60:array-decl #'unknown $2)]
314 |                          [(<local-or-own-type> ARRAY <array-list>) (make-a60:array-decl $1 $3)])
315 |     ;; -------------------- Switches --------------------
316 |     (<switch-list> [(<designational-expression>) (list $1)]
317 |                    [(<switch-list> COMMA <designational-expression>) (append $1 (list $3))])
318 |     (<switch-declaration> [(SWITCH <switch-identifier> ASSIGN <switch-list>) (make-a60:switch-decl $2 $4)])
319 |     ;; -------------------- Procedures --------------------
320 |     (<formal-parameter> [(<identifier>) $1])
321 |     (<formal-parameter-list> [(<formal-parameter>) (list $1)]
322 |                              [(<formal-parameter-list> <parameter-delimiter> <formal-parameter>) 
323 |                               (append $1 (list $3))])
324 |     (<formal-parameter-part> [() null]
325 |                              [(OPEN <formal-parameter-list> CLOSE) $2])
326 |     (<identifier-list> [(<identifier>) (list $1)]
327 |                        [(<identifier-list> COMMA <identifier>) (append $1 (list $3))])
328 |     (<value-part> [(VALUE <identifier-list> SEMICOLON) $2]
329 |                   [() null])
330 |     (<specifier> [(STRING) 'string]
331 |                  [(<type>) $1]
332 |                  [(ARRAY) '(array #'unknown)]
333 |                  [(<type> ARRAY) `(array ,$1)]
334 |                  [(LABEL) 'label]
335 |                  [(SWITCH) 'switch]
336 |                  [(PROCEDURE) '(procedure #'unknown)]
337 |                  [(<type> PROCEDURE) `(procedure ,$1)])
338 |     (<nonempty-specification-part> [(<specifier> <identifier-list> SEMICOLON) (list (cons $1 $2))]
339 |                                    [(<nonempty-specification-part> <specifier> <identifier-list> SEMICOLON)
340 |                                     (append $1 (list (cons $2 $3)))])
341 |     (<specification-part> [() null]
342 |                           [(<nonempty-specification-part>) $1])
343 |     (<procedure-heading> [(<identifier> <formal-parameter-part> SEMICOLON <value-part> <specification-part>)
344 |                           (list $1 $2 $4 $5)])
345 |     (<procedure-body> [(<nonempty-statement>) $1])
346 |     (<procedure-declaration> [(PROCEDURE <procedure-heading> <procedure-body>)
347 |                               (make-a60:proc-decl #'unknown (car $2) (cadr $2) (caddr $2) (cadddr $2) $3)]
348 |                              [(<type> PROCEDURE <procedure-heading> <procedure-body>)
349 |                               (make-a60:proc-decl $1 (car $3) (cadr $3) (caddr $3) (cadddr $3) $4)])
350 |     ;; ==================== Program ====================
351 |     (<program> [(<block>) $1]
352 |                [(<compound-statement>) $1]))))
353 | 
354 | (define-syntax (define-a60-structs stx)
355 |   (syntax-case stx ()
356 |     [(_ (struct-name (field ...)) ...)
357 |      (with-syntax ([(a60:struct ...) (map (lambda (id)
358 |                                             (datum->syntax
359 |                                              id
360 |                                              (string->symbol
361 |                                               (format "a60:~a" (syntax-e id)))))
362 |                                           (syntax->list (syntax (struct-name ...))))])
363 |        (syntax (begin (define-struct a60:struct (field ...)) ...
364 |                       (provide (struct-out a60:struct) ...))))]))
365 | 
366 | (define-a60-structs
367 |   ;; Expressions
368 |   (if (test then else))
369 |   (unary (type argtype op arg))
370 |   (binary (type argtype op arg1 arg2))
371 |   (subscript (array index))
372 |   (variable (name indices))
373 |   (app (func args))
374 |   ;; plus numbers, strings, and booleans
375 |   
376 |   ;; Statements
377 |   (block (decls statements))
378 |   (compound (statements))
379 |   (assign (variables rhs))
380 |   (goto (target))
381 |   (branch (test then else))
382 |   (call (proc args))
383 |   (for (variable values body))
384 |   (dummy ())
385 |   (label (name statement))
386 |   
387 |   ;; for values
388 |   (for-number (value))
389 |   (for-step (start step end))
390 |   (for-while (value test))
391 |   
392 |   ;; declarations
393 |   (type-decl (type vars))
394 |   (array-decl (type vars))
395 |   (switch-decl (var cases))
396 |   (proc-decl (result-type var arg-vars by-value-vars arg-specs body)))
397 | 
398 | (define (parse-a60-port port file)
399 |   (let ([lexer (lex file)])
400 |     (port-count-lines! port)
401 |     (parse
402 |      (lambda () 
403 |        (let loop ()
404 |          (let ([v (lexer port)])
405 |            (if (void? v)
406 |                (loop)
407 |                v)))))))
408 | 
409 | (define (parse-a60-file file)
410 |   (with-input-from-file file
411 |     (lambda ()
412 |       (parse-a60-port (current-input-port)
413 |                       (path->complete-path file)))))
414 | 


--------------------------------------------------------------------------------
/compile.rkt:
--------------------------------------------------------------------------------
  1 | #lang racket
  2 | (require "parse.rkt"
  3 |          racket/match)
  4 | 
  5 | (provide compile-simplified)
  6 | 
  7 | ;; The compiler generates references to "prims.rkt" and
  8 | ;; "runtime.rkt" exports, as well as Racket forms
  9 | ;; and functions. The `ctx' argument provides
 10 | ;; an appropriate context for those bindings (in
 11 | ;; the form of a syntax object to use with d->s-o).
 12 | (define (compile-simplified stmt ctx #:module-exports? [module-exports? #f])
 13 |   (datum->syntax 
 14 |    ctx
 15 |    (parameterize ([current-compile-context ctx])
 16 |      (compile-a60 stmt 'void (empty-context) #t module-exports?))))
 17 | 
 18 | (define current-compile-context (make-parameter #f))
 19 | 
 20 | (define (compile-a60 stmt next-label context add-to-top-level? module-exports?)
 21 |   (match stmt
 22 |     [(a60:block decls statements)
 23 |      (compile-block decls statements next-label context add-to-top-level?)]
 24 |     [else
 25 |      (compile-statement stmt next-label context)]))
 26 | 
 27 | (define (compile-block decls statements next-label context add-to-top-level?)
 28 |   (let* ([labels-with-numbers (map car statements)]
 29 |          [labels (map (lambda (l)
 30 |                         (if (stx-number? l)
 31 |                             (datum->syntax
 32 |                              l
 33 |                              (string->symbol (format "~a" (syntax-e l)))
 34 |                              l
 35 |                              l)
 36 |                             l))
 37 |                       labels-with-numbers)]
 38 |          ;; Build environment by adding labels, then decls:
 39 |          [context (foldl (lambda (decl context)
 40 |                            (match decl
 41 |                              [(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
 42 |                               (add-procedure context var result-type arg-vars by-value-vars arg-specs)]
 43 |                              [(a60:type-decl type ids)
 44 |                               (add-atoms context ids type)]
 45 |                              [(a60:array-decl type arrays)
 46 |                               (add-arrays context 
 47 |                                           (map car arrays) ; names
 48 |                                           (map cdr arrays) ; dimensions
 49 |                                           type)]
 50 |                              [(a60:switch-decl name exprs)
 51 |                               (add-switch context name)]))
 52 |                          (add-labels
 53 |                           context
 54 |                           labels)
 55 |                          decls)])
 56 |     ;; Generate bindings and initialization for all decls,
 57 |     ;; plus all statements (thunked):
 58 |     (let ([bindings
 59 |            (append
 60 |             (apply
 61 |              append
 62 |              ;; Decls:
 63 |              (map (lambda (decl)
 64 |                     (match decl
 65 |                       [(a60:proc-decl result-type var arg-vars by-value-vars arg-specs body)
 66 |                        (let ([code
 67 |                               `(lambda (kont . ,arg-vars)
 68 |                                  ;; Include the declaration variables
 69 |                                  ,@(for/list ([arg-spec (in-list arg-specs)])
 70 |                                      `(void ,@(cdr arg-spec)))
 71 |                                  ;; Extract by-value variables
 72 |                                  (let ,(map (lambda (var)
 73 |                                               `[,var (get-value ,var)])
 74 |                                             by-value-vars)
 75 |                                    ;; Set up the result variable and done continuation:
 76 |                                    ,(let ([result-var (gensym 'prec-result)]
 77 |                                           [done (gensym 'done)])
 78 |                                       `(let* ([,result-var undefined]
 79 |                                               [,done (lambda () (kont ,result-var))])
 80 |                                          ;; Include the compiled body:
 81 |                                          ,(compile-a60 body done
 82 |                                                        (add-settable-procedure
 83 |                                                         (add-bindings
 84 |                                                          context
 85 |                                                          arg-vars
 86 |                                                          by-value-vars
 87 |                                                          arg-specs)
 88 |                                                         var
 89 |                                                         result-type
 90 |                                                         result-var)
 91 |                                                        #f
 92 |                                                        #f)))))])
 93 |                          (if add-to-top-level?
 94 |                              (let ([exported (gensym 'exported)])
 95 |                                (list
 96 |                                 `(define ,var ,code)
 97 |                                 `(define ,exported
 98 |                                    (let ([,var (λ args
 99 |                                                 (apply ,var (λ (x) x)
100 |                                                        (map (λ (x) (λ () x)) args)))])
101 |                                      ,var))
102 |                                 `(provide (rename-out [,exported ,var]))
103 |                                 `(namespace-set-variable-value! ',var ,var)))
104 |                              (list
105 |                               `(define ,var
106 |                                  ,code))))]
107 |                       [(a60:type-decl type ids)
108 |                        (map (lambda (id) `(define ,id undefined)) ids)]
109 |                       [(a60:array-decl type arrays)
110 |                        (map (lambda (array) 
111 |                               `(define ,(car array)
112 |                                  (make-array
113 |                                   ,@(apply
114 |                                      append
115 |                                      (map
116 |                                       (lambda (bp)
117 |                                         (list
118 |                                          (compile-expression (car bp) context 'num)
119 |                                          (compile-expression (cdr bp) context 'num)))
120 |                                       (cdr array))))))
121 |                             arrays)]
122 |                       [(a60:switch-decl name exprs)
123 |                        (list
124 |                         `(define ,name (make-switch ,@(map (lambda (e) `(lambda () ,(compile-expression e context 'des)))
125 |                                                            exprs))))]
126 |                       [else (error "can't compile decl")]))
127 |                   decls))
128 |             ;; Statements: most of the work is in `compile-statement', but
129 |             ;;  we provide the continuation label:
130 |             (cdr
131 |              (foldr (lambda (stmt label next-label+compiled)
132 |                       (cons label
133 |                             (cons
134 |                              `(define ,label
135 |                                (lambda ()
136 |                                  ,(compile-statement (cdr stmt) 
137 |                                                      (car next-label+compiled)
138 |                                                      context)))
139 |                              (cdr next-label+compiled))))
140 |                     (cons next-label null)
141 |                     statements
142 |                     labels)))])
143 |       ;; Check for duplicate bindings:
144 |       (let ([dup
145 |              (check-duplicate-identifier
146 |               (for/list ([binding (in-list bindings)]
147 |                          #:when (match binding
148 |                                   [`(define ,(? identifier? id) ,exp) #t]
149 |                                   [_ #f]))
150 |                 (list-ref binding 1)))])
151 |         (when dup
152 |           (raise-syntax-error
153 |            #f
154 |            "name defined twice"
155 |            dup)))
156 |       ;; Generate code; body of leterec jumps to the first statement label.
157 |       (if add-to-top-level?
158 |           `(begin
159 |              ,@bindings
160 |              (,(caar statements)))
161 |           `(let ()
162 |              ,@bindings
163 |              (,(caar statements)))))))
164 | 
165 | (define (compile-statement statement next-label context)
166 |   (match statement
167 |     [(a60:block decls statements)
168 |      (compile-block decls statements next-label context #f)]
169 |     [(a60:branch test (a60:goto then) (a60:goto else))
170 |      `(if (check-boolean ,(compile-expression test context 'bool))
171 |           (goto ,(check-label then context))
172 |           (goto ,(check-label else context)))]
173 |     [(a60:goto label)
174 |      (at (expression-location label)
175 |          `(goto ,(compile-expression label context 'des)))]
176 |     [(a60:dummy)
177 |      `(,next-label)]
178 |     [(a60:call proc args)
179 |      (at (expression-location proc)
180 |          `(,(compile-expression proc context 'func)
181 |            (lambda (val) 
182 |              (,next-label))
183 |            ,@(map (lambda (arg) (compile-argument arg context))
184 |                   args)))]
185 |     [(a60:assign vars val)
186 |      ;; >>>>>>>>>>>>>>> Start clean-up here <<<<<<<<<<<<<<<<<
187 |      ;; Lift out the spec-finding part, and use it to generate
188 |      ;; an expected type that is passed to `compile-expression':
189 |      `(begin
190 |         (let ([val ,(compile-expression val context 'numbool)])
191 |           ,@(map (lambda (avar)
192 |                    (let ([var (a60:variable-name avar)])
193 |                      (at var
194 |                          (cond
195 |                            [(null? (a60:variable-indices avar))
196 |                             (cond
197 |                               [(call-by-name-variable? var context)
198 |                                => (lambda (spec)
199 |                                     `(set-target! ,var ',var (coerce ',(spec-coerce-target spec null) val)))]
200 |                               [(procedure-result-variable? var context)
201 |                                `(set! ,(procedure-result-variable-name var context) 
202 |                                       (coerce ',(spec-coerce-target (procedure-result-spec var context) null) val))]
203 |                               [(or (settable-variable? var context)
204 |                                    (array-element? var context))
205 |                                => (lambda (spec)
206 |                                     `(,(if (own-variable? var context) 'set-box! 'set!)
207 |                                       ,var
208 |                                       (coerce ',(spec-coerce-target spec null) val)))]
209 |                               [else (raise-syntax-error #f "confused by assignment" (expression-location var))])]
210 |                            [else
211 |                             (let ([spec (or (array-element? var context)
212 |                                             (call-by-name-variable? var context))])
213 |                               `(array-set! ,(compile-expression (make-a60:variable var null) context 'numbool)
214 |                                            (coerce ',(spec-coerce-target spec null) val)
215 |                                            ,@(map (lambda (e) (compile-expression e context 'num)) 
216 |                                                   (a60:variable-indices avar))))]))))
217 |                  vars))
218 |         (,next-label))]
219 |     [else (error "can't compile statement")]))
220 | 
221 | (define (compile-expression expr context type)
222 |   (match expr
223 |     [(? (lambda (x) (and (syntax? x) (number? (syntax-e x)))) n) 
224 |      (if (eq? type 'des)
225 |          ;; Need a label:
226 |          (check-label (datum->syntax expr
227 |                                             (string->symbol (number->string (syntax-e expr)))
228 |                                             expr
229 |                                             expr)
230 |                       context)
231 |          ;; Normal use of a number:
232 |          (begin
233 |            (check-type 'num type expr) 
234 |            (as-builtin n)))]
235 |     [(? (lambda (x) (and (syntax? x) (boolean? (syntax-e x)))) n) (check-type 'bool type expr) (as-builtin n)]
236 |     [(? (lambda (x) (and (syntax? x) (string? (syntax-e x)))) n)  (check-type 'string type expr) (as-builtin n)]
237 |     [(? identifier? i) (compile-expression (make-a60:variable i null) context type)]
238 |     [(? symbol? i) ; either a generated label or 'val:
239 |      (unless (eq? expr 'val)
240 |        (check-type 'des type expr))
241 |      (datum->syntax #f i)]
242 |     [(a60:subscript array index)
243 |      ;; Maybe a switch index, or maybe an array reference
244 |      (at array
245 |          (cond
246 |            [(array-element? array context)
247 |             `(array-ref ,array ,(compile-expression index context 'num))]
248 |            [(switch-variable? array context)
249 |             `(switch-ref ,array ,(compile-expression index context 'num))]
250 |            [else (raise-syntax-error
251 |                   #f
252 |                   "confused by variable"
253 |                   array)]))]
254 |     [(a60:binary t argt op e1 e2)
255 |      (check-type t type expr)
256 |      (at op
257 |          `(,(as-builtin op) ,(compile-expression e1 context argt) ,(compile-expression e2 context argt)))]
258 |     [(a60:unary t argt op e1)
259 |      (check-type t type expr)
260 |      (at op
261 |          `(,(as-builtin op) ,(compile-expression e1 context argt)))]
262 |     [(a60:variable var subscripts)
263 |      (let ([sub (lambda (wrap v)
264 |                   (wrap
265 |                    (if (null? subscripts)
266 |                        v
267 |                        `(array-ref ,v ,@(map (lambda (e) (compile-expression e context 'num)) subscripts)))))])
268 |        (cond
269 |          [(call-by-name-variable? var context)
270 |           => (lambda (spec)
271 |                (check-spec-type spec type var subscripts)
272 |                (sub (lambda (val) `(coerce ',(spec-coerce-target spec subscripts) ,val)) `(get-value ,var)))]
273 |          [(primitive-variable? var context)
274 |           => (lambda (name)
275 |                (sub values
276 |                     (datum->syntax
277 |                      (current-compile-context)
278 |                      name
279 |                      var
280 |                      var)))]
281 |          [(and (procedure-result-variable? var context)
282 |                (not (eq? type 'func)))
283 |           (unless (null? subscripts)
284 |             (raise-syntax-error "confused by subscripts" var))
285 |           (let ([spec (procedure-result-spec var context)])
286 |             (check-spec-type spec type var null)
287 |             (at var
288 |                 `(coerce
289 |                   ',(spec-coerce-target spec null)
290 |                   ,(procedure-result-variable-name var context))))]
291 |          [(or (procedure-result-variable? var context)
292 |               (procedure-variable? var context)
293 |               (label-variable? var context)
294 |               (settable-variable? var context)
295 |               (array-element? var context))
296 |           => (lambda (spec)
297 |                (let ([spec (if (or (procedure-result-variable? var context)
298 |                                    (procedure-variable? var context)
299 |                                    (and (array-element? var context)
300 |                                         (null? subscripts)))
301 |                                #f ;; need just the proc or array...
302 |                                spec)])
303 |                  (check-spec-type spec type var subscripts)
304 |                  (let ([target (spec-coerce-target spec subscripts)])
305 |                    (sub (if target
306 |                             (lambda (v) `(coerce ',target ,v))
307 |                             values)
308 |                         (if (own-variable? var context)
309 |                             `(unbox ,var)
310 |                             var)))))]
311 |          [else (raise-syntax-error
312 |                 #f
313 |                 "confused by expression"
314 |                 (expression-location var))]))]
315 |     
316 |     [(a60:app func args)
317 |      (at (expression-location func)
318 |          `(,(compile-expression func context 'func)
319 |            values
320 |            ,@(map (lambda (e) (compile-argument e context))
321 |                   args)))]
322 |     [(a60:if test then else)
323 |      `(if (check-boolean ,(compile-expression test context 'bool))
324 |           ,(compile-expression then context type)
325 |           ,(compile-expression else context type))]
326 |     [else (error 'compile-expression "can't compile expression ~a" expr)]))
327 | 
328 | (define (expression-location expr)
329 |   (if (syntax? expr)
330 |       expr
331 |       (match expr
332 |         [(a60:subscript array index) (expression-location array)]
333 |         [(a60:binary type argtype op e1 e2) op]
334 |         [(a60:unary type argtype op e1) op]
335 |         [(a60:variable var subscripts) (expression-location var)]
336 |         [(a60:app func args)
337 |          (expression-location func)]
338 |         [else #f])))
339 | 
340 | (define (compile-argument arg context)
341 |   (cond
342 |     [(or (and (a60:variable? arg)
343 |               (not (let ([v  (a60:variable-name arg)])
344 |                      (or (procedure-variable? v context)
345 |                          (label-variable? v context)
346 |                          (primitive-variable? v context)))))
347 |          (a60:subscript? arg))
348 |      (let ([arg (if (a60:subscript? arg)
349 |                     (make-a60:variable (a60:subscript-array arg)
350 |                                        (list (a60:subscript-index arg)))
351 |                     arg)])
352 |        `(case-lambda
353 |           [() ,(compile-expression arg context 'any)]
354 |           [(val)  ,(compile-statement (make-a60:assign (list arg) 'val) 'void context)]))]
355 |     [(identifier? arg)
356 |      (compile-argument (make-a60:variable arg null) context)]
357 |     [else `(lambda () ,(compile-expression arg context 'any))]))
358 | 
359 | (define (check-type got expected expr)
360 |   (or (eq? expected 'any)
361 |       (case got
362 |         [(num) (memq expected '(num numbool))]
363 |         [(bool) (memq expected '(bool numbool))]
364 |         [(des) (memq expected '(des))]
365 |         [(func) (memq expected '(func))]
366 |         [else #f])
367 |       (raise-syntax-error #f
368 |                           (format "type mismatch (~a != ~a)" got expected)
369 |                           expr)))
370 | 
371 | (define (check-spec-type spec type expr subscripts)
372 |   (let ([target (spec-coerce-target spec subscripts)])
373 |     (when target
374 |       (case (syntax-e target)
375 |         [(integer real) (check-type 'num type expr)]
376 |         [(boolean) (check-type 'bool type expr)]
377 |         [(procedure) (check-type 'func type expr)]))))
378 | 
379 | 
380 | (define (check-label l context)
381 |   (if (or (symbol? l)
382 |           (label-variable? l context))
383 |       l
384 |       (raise-syntax-error
385 |        #f
386 |        "undefined label"
387 |        l)))
388 | 
389 | (define (at stx expr)
390 |   (if (syntax? stx)
391 |       (datum->syntax (current-compile-context) expr stx)
392 |       expr))
393 | 
394 | (define (as-builtin stx)
395 |   ;; Preserve source loc, but change to reference to
396 |   ;; a builtin operation by changing the context:
397 |   (datum->syntax
398 |    (current-compile-context)
399 |    (syntax-e stx)
400 |    stx
401 |    stx))
402 | 
403 | ;; --------------------
404 | 
405 | (define (empty-context)
406 |   `(((sign prim sign)
407 |      (entier prim entier)
408 |      
409 |      (sin prim a60:sin)
410 |      (cos prim a60:cos)
411 |      (acrtan prim a60:arctan)
412 |      (sqrt prim a60:sqrt)
413 |      (abs prim a60:abs)
414 |      (ln prim a60:ln)
415 |      (exp prim a60:exp)
416 |      
417 |      (prints prim prints)
418 |      (printn prim printn)
419 |      (printsln prim printsln)
420 |      (printnln prim printnln))))
421 | 
422 | (define (add-labels context l)
423 |   (cons (map (lambda (lbl) (cons (if (symbol? lbl)
424 |                                      (datum->syntax #f lbl)
425 |                                      lbl)
426 |                                  'label)) l)
427 |         context))
428 | 
429 | (define (add-procedure context var result-type arg-vars by-value-vars arg-specs)
430 |   (cons (list (cons var 'procedure))
431 |         context))
432 | 
433 | (define (add-settable-procedure context var result-type result-var)
434 |   (cons (list (cons var `(settable-procedure ,result-var ,result-type)))
435 |         context))
436 | 
437 | (define (add-atoms context ids type)
438 |   (cons (map (lambda (id) (cons id type)) ids)
439 |         context))
440 | 
441 | (define (add-arrays context names dimensionses type)
442 |   (cons (map (lambda (name dimensions)
443 |                (cons name `(array ,type ,(length dimensions))))
444 |              names dimensionses)
445 |         context))
446 | 
447 | (define (add-switch context name)
448 |   (cons (list (cons name 'switch))
449 |         context))
450 | 
451 | (define (add-bindings context arg-vars by-value-vars arg-specs)
452 |   (cons (map (lambda (var)
453 |                (let ([spec (or (ormap (lambda (spec)
454 |                                         (and (ormap (lambda (x) (bound-identifier=? var x))
455 |                                                     (cdr spec))
456 |                                              (car spec)))
457 |                                       arg-specs)
458 |                                #'unknown)])
459 |                  (cons var
460 |                        (if (ormap (lambda (x) (bound-identifier=? var x)) by-value-vars)
461 |                            spec
462 |                            (list 'by-name spec)))))
463 |              arg-vars)
464 |         context))
465 | 
466 | ;; var-binding : syntax context -> symbol
467 | ;; returns an identifier indicating where the var is
468 | ;; bound, or 'free if it isn't. The compiler inserts
469 | ;; top-level procedure definitions into the namespace; if 
470 | ;; the variable is bound there, it is a procedure.
471 | (define (var-binding var context)
472 |   (cond
473 |     [(null? context)
474 |      (let/ec k
475 |        (namespace-variable-value (syntax-e var)
476 |                                  #t 
477 |                                  (lambda () (k 'free)))
478 |        'procedure)]
479 |     [else
480 |      (let ([m (var-in-rib var (car context))])
481 |        (or m (var-binding var (cdr context))))]))
482 | 
483 | (define (var-in-rib var rib)
484 |   (ormap (lambda (b)
485 |            (if (symbol? (car b))
486 |                ;; primitives:
487 |                (and (eq? (syntax-e var) (car b))
488 |                     (cdr b))
489 |                ;; everything else:
490 |                (and (bound-identifier=? var (car b))
491 |                     (cdr b))))
492 |          rib))
493 | 
494 | (define (primitive-variable? var context)
495 |   (let ([v (var-binding var context)])
496 |     (and (pair? v)
497 |          (eq? (car v) 'prim)
498 |          (cadr v))))
499 | 
500 | (define (call-by-name-variable? var context)
501 |   (let ([v (var-binding var context)])
502 |     (and (pair? v)
503 |          (eq? (car v) 'by-name)
504 |          (cadr v))))
505 | 
506 | (define (procedure-variable? var context)
507 |   (let ([v (var-binding var context)])
508 |     (eq? v 'procedure)))
509 | 
510 | (define (procedure-result-variable? var context)
511 |   (let ([v (var-binding var context)])
512 |     (and (pair? v)
513 |          (eq? (car v) 'settable-procedure)
514 |          (cdr v))))
515 | 
516 | (define (procedure-result-variable-name var context)
517 |   (let ([v (procedure-result-variable? var context)])
518 |     (car v)))
519 | 
520 | (define (procedure-result-spec var context)
521 |   (let ([v (procedure-result-variable? var context)])
522 |     (cadr v)))
523 | 
524 | (define (label-variable? var context)
525 |   (let ([v (var-binding var context)])
526 |     (eq? v 'label)))
527 | 
528 | (define (switch-variable? var context)
529 |   (let ([v (var-binding var context)])
530 |     (eq? v 'switch)))
531 | 
532 | (define (settable-variable? var context)
533 |   (let ([v (var-binding var context)])
534 |     (or (box? v)
535 |         (and (syntax? v)
536 |              (memq (syntax-e v) '(integer real boolean))
537 |              v))))
538 | 
539 | (define (own-variable? var context)
540 |   (let ([v (var-binding var context)])
541 |     (box? v)))
542 | 
543 | (define (array-element? var context)
544 |   (let ([v (var-binding var context)])
545 |     (and (pair? v)
546 |          (eq? (car v) 'array)
547 |          (or (cadr v)
548 |              #'unknown))))
549 | 
550 | (define (spec-coerce-target spec subscripts)
551 |   (cond
552 |     [(and (syntax? spec) (memq (syntax-e spec) '(string label switch real integer boolean unknown))) spec]
553 |     [(and (syntax? spec) (memq (syntax-e spec) '(unknown))) #f]
554 |     [(or (not spec) (not (pair? spec))) #f]
555 |     [(eq? (car spec) 'array) (if (null? subscripts) #'array (cadr spec))]
556 |     [(eq? (car spec) 'procedure) #'procedure]
557 |     [else #f]))
558 | 
559 | (define (stx-number? a) (and (syntax? a) (number? (syntax-e a))))
560 | 


--------------------------------------------------------------------------------