|
|
@ -8,13 +8,26 @@
|
|
|
|
; BASIC implementation details
|
|
|
|
; BASIC implementation details
|
|
|
|
; http://www.atariarchives.org/basicgames/showpage.php?page=i12
|
|
|
|
; http://www.atariarchives.org/basicgames/showpage.php?page=i12
|
|
|
|
|
|
|
|
|
|
|
|
(define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
|
|
|
|
(begin-for-syntax
|
|
|
|
|
|
|
|
(require racket/match racket/list)
|
|
|
|
(define-macro (basic-module-begin . PROGRAM-LINES)
|
|
|
|
(define (gather-unique-ids stx)
|
|
|
|
#'(#%module-begin
|
|
|
|
(define ids empty)
|
|
|
|
(inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
|
|
|
|
(let loop ([x (syntax->datum stx)])
|
|
|
|
(println (quote . PROGRAM-LINES))
|
|
|
|
(match x
|
|
|
|
. PROGRAM-LINES)))
|
|
|
|
[(or (list 'statement (? symbol? id-name) "=" etc ...)
|
|
|
|
|
|
|
|
(list 'statement "input" (list 'print-list etc ...) (? symbol? id-name) ...)
|
|
|
|
|
|
|
|
(list 'statement "for" (? symbol? id-name) etc ...)) (set! ids (cons id-name ids))]
|
|
|
|
|
|
|
|
[(? list?) (map loop x)]
|
|
|
|
|
|
|
|
[else #f]))
|
|
|
|
|
|
|
|
(remove-duplicates (flatten ids) eq?)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-macro (basic-module-begin (basic-program PROGRAM-LINE ...))
|
|
|
|
|
|
|
|
(with-pattern
|
|
|
|
|
|
|
|
([(UNIQUE-ID ...) (map (compose1 syntax-local-introduce (λ(id) (datum->syntax #f id)))
|
|
|
|
|
|
|
|
(gather-unique-ids #'(PROGRAM-LINE ...)))])
|
|
|
|
|
|
|
|
#'(#%module-begin
|
|
|
|
|
|
|
|
(define UNIQUE-ID 0) ...
|
|
|
|
|
|
|
|
(run PROGRAM-LINE ...))))
|
|
|
|
|
|
|
|
|
|
|
|
; #%app and #%datum have to be present to make #%top work
|
|
|
|
; #%app and #%datum have to be present to make #%top work
|
|
|
|
(define-macro (basic-top . ID)
|
|
|
|
(define-macro (basic-top . ID)
|
|
|
@ -22,8 +35,6 @@
|
|
|
|
(displayln (format "got unbound identifier: ~a" 'ID))
|
|
|
|
(displayln (format "got unbound identifier: ~a" 'ID))
|
|
|
|
(procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
|
|
|
|
(procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
|
|
|
|
|
|
|
|
|
|
|
|
(define-macro (basic-program LINE ...) #'(run (list LINE ...)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(struct exn:line-not-found exn:fail ())
|
|
|
|
(struct exn:line-not-found exn:fail ())
|
|
|
|
(define (raise-line-not-found-error ln)
|
|
|
|
(define (raise-line-not-found-error ln)
|
|
|
|
(raise
|
|
|
|
(raise
|
|
|
@ -39,7 +50,7 @@
|
|
|
|
(define (raise-line-end-error)
|
|
|
|
(define (raise-line-end-error)
|
|
|
|
(raise (exn:line-end "" (current-continuation-marks))))
|
|
|
|
(raise (exn:line-end "" (current-continuation-marks))))
|
|
|
|
|
|
|
|
|
|
|
|
(define (run line-list)
|
|
|
|
(define (run . line-list)
|
|
|
|
(define lines (list->vector line-list))
|
|
|
|
(define lines (list->vector line-list))
|
|
|
|
(define (find-index ln)
|
|
|
|
(define (find-index ln)
|
|
|
|
(or
|
|
|
|
(or
|
|
|
@ -150,8 +161,8 @@
|
|
|
|
(basic:input ID) ...)]
|
|
|
|
(basic:input ID) ...)]
|
|
|
|
[(_ ID ...) #'(begin
|
|
|
|
[(_ ID ...) #'(begin
|
|
|
|
(set! ID (let* ([str (read-line)]
|
|
|
|
(set! ID (let* ([str (read-line)]
|
|
|
|
[num (string->number str)])
|
|
|
|
[num (string->number str)])
|
|
|
|
(or num str))) ...)])
|
|
|
|
(or num str))) ...)])
|
|
|
|
|
|
|
|
|
|
|
|
(define (basic:goto where) where)
|
|
|
|
(define (basic:goto where) where)
|
|
|
|
|
|
|
|
|
|
|
|