algol60/tool.rkt at master · racket/algol60 · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
#lang racket/base
(require drracket/tool
         racket/gui
         racket/unit
         racket/class
         "parse.rkt"
         "simplify.rkt"
         "compile.rkt"
         compiler/embed
         string-constants
         errortrace/errortrace-lib)

(provide tool@)

(define base-importing-stx (dynamic-require 'algol60/base
                                            'base-importing-stx))

(define-unit tool@
    (import drracket:tool^)
    (export drracket:tool-exports^)

    (define (phase1) (void))
    (define (phase2)
      (drracket:language-configuration:add-language
       (make-object (override-mrflow-methods
                     ((drracket:language:get-default-mixin)
                      lang%)))))

    (define (override-mrflow-methods %)
      (if (method-in-interface? 'render-value-set (class->interface %))
          (class %
            (inherit [super-render-value-set render-value-set]
                     [super-get-mrflow-primitives-filename get-mrflow-primitives-filename])
            (define/override (render-value-set . x)
              ;; needs to be filled in!
              (super-render-value-set . x))
            (define/override (get-mrflow-primitives-filename)
              (build-path (collection-path "mrflow")
                          "primitives"
                          "algol60.rkt"))
            (super-instantiate ()))
          %))

    (define lang%
      (class* object% (drracket:language:language<%>)
        (define/public (front-end/finished-complete-program settings) (void))
        (define/public (extra-repl-information settings port) (void))
        (define/public (get-reader-module) #f)
        (define/public (get-metadata a b) #f)
        (define/public (metadata->settings m) #f)
        (define/public (get-metadata-lines) #f)

        (define/public (capability-value s) (drracket:language:get-capability-default s))
        (define/public (first-opened) (void))
        (define/public (config-panel parent)
          (case-lambda
            [() null]
            [(x) (void)]))
        (define/public (get-comment-character) (values "'COMMENT'" #\*))
        (define/public (default-settings) null)
        (define/public (default-settings? x) #t)
        (define/private (front-end port settings)
          (let ([name (object-name port)])
            (lambda ()
              (if (eof-object? (peek-char port))
                  eof
                  (compile-simplified
                   (simplify (parse-a60-port port name) base-importing-stx)
                   base-importing-stx)))))
        (define/public (front-end/complete-program port settings) (front-end port settings))
        (define/public (front-end/interaction port settings) (front-end port settings))
        (define/public (get-style-delta) #f)
        (define/public (get-language-position)
          (list (string-constant experimental-languages)
                "Algol 60"))
        (define/public (get-language-name) "Algol 60")
        (define/public (get-language-url) #f)
        (define/public (get-language-numbers) (list 1000 10))
        (define/public (get-teachpack-names) null)
        (define/public (marshall-settings x) x)
        (define/public (on-execute settings run-in-user-thread)
          (dynamic-require 'algol60/base #f)
          (let ([path ((current-module-name-resolver) 'algol60/base #f #f)]
                [n (current-namespace)])
            (run-in-user-thread
             (lambda ()
               (error-display-handler
                (drracket:debug:make-debug-error-display-handler (error-display-handler)))
               (current-compile (make-errortrace-compile-handler))
               (with-handlers ([void (lambda (x)
                                       (printf "~a\n"
                                               (exn-message x)))])
                 (namespace-attach-module n path)
                 (namespace-require path))))))
        (define/public (render-value value settings port) (write value port))
        (define/public (render-value/format value settings port width) (write value port))
        (define/public (unmarshall-settings x) x)
        (define/public (create-executable settings parent src-file)
          (let ([dst-file (drracket:language:put-executable
                           parent src-file #f #f
                           (string-constant save-a-mzscheme-stand-alone-executable))])
            (when dst-file
              (let ([code (compile-simplified (simplify (parse-a60-file src-file)
                                                        base-importing-stx)
                                              base-importing-stx)])
                (make-embedding-executable dst-file
                                           #f #f
                                           '((#f algol60/base))
                                           null
                                           (compile
                                            `(module m algol60/base
                                               ,code))
                                           (list "-mvqe" "(require m)"))))))
        (define/public (get-one-line-summary) "Of historic interest")

        (super-instantiate ()))))