From d850b0dadf612ab60384048e824b0633a5327cae Mon Sep 17 00:00:00 2001 From: Artsiom Dzenisiuk Date: Thu, 30 Oct 2025 15:14:02 +0100 Subject: [PATCH] Switched to r7rs standard --- fudge-chez.ss | 101 ------------------------------------ fudge.ss | 140 ++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 140 insertions(+), 101 deletions(-) delete mode 100644 fudge-chez.ss create mode 100755 fudge.ss diff --git a/fudge-chez.ss b/fudge-chez.ss deleted file mode 100644 index 7c53faf..0000000 --- a/fudge-chez.ss +++ /dev/null @@ -1,101 +0,0 @@ -(import (rnrs)) - -(define get-word - (lambda (file) - (let ([c (lookahead-char file)]) - (cond - [(eof-object? c) ""] - [(char-alphabetic? c) - (get-char file) - (string-append (string c) (get-word file))] - [else ""])))) - -(define char->digit - (lambda (c) - (- (char->integer c) (char->integer #\0)))) - -; get-number supports only nonnegative integers. -(define get-number - (lambda (file) - (let f ([total 0]) - (let ([c (lookahead-char file)]) - (if (char-numeric? c) - (begin - (get-char file) - (f (+ (* total 10) (char->digit c)))) - total))))) - -(define get-token - (lambda (file) - (let ([c (lookahead-char file)]) - (cond - [(eof-object? c) 'end-of-file] - [(char-whitespace? c) - (get-char file) - (get-token file)] - [(char-alphabetic? c) - (get-word file)] - [(char-numeric? c) - (get-number file)] - [(eq? c #\+) (get-char file) '+] - [(eq? c #\-) (get-char file) '-] - [(eq? c #\*) (get-char file) '*] - [(eq? c #\/) (get-char file) '/] - [(eq? c #\=) (get-char file) #\=] - [else (error 'get-token "Bad character" c)])))) - -(define get-tokens - (lambda (file) - (let ([token (get-token file)]) - (if (eq? token 'end-of-file) - '() - (cons token (get-tokens file)))))) - -(define tokenize - (lambda (filename) - (let ([file (open-input-file filename)]) - (get-tokens file)))) - -(define test-lexer-fail - (lambda (input want got) - (display "text-lexer-fail: input=") - (write input) - (display "; want: ") - (write want) - (display "; got: ") - (write got) - (display ".") - (newline))) - -(define test-lexer-success - (lambda (input got) - (display "text-lexer-success: input=") - (write input) - (display "; got: ") - (write got) - (display ".") - (newline))) - -(define test-lexer - (lambda (input want) - (let ([port (open-string-input-port input)]) - (call/cc - (lambda (i-got-exception) - (with-exception-handler - (lambda (x) - (display "test-lexer-fail: input ") - (write input) - (display " throws ") - (write x) - (display ".") - (newline) - (i-got-exception x)) - (lambda () - (let ([got (get-tokens port)]) - (if (equal? got want) - (test-lexer-success input got) - (test-lexer-fail input want got)))))))))) - -(test-lexer "hello world" '("hello" "world")) -(test-lexer "+ * / -" '(+ * / -)) -(test-lexer "identifier = 14" '("identifier" = 14)) diff --git a/fudge.ss b/fudge.ss new file mode 100755 index 0000000..fc39d49 --- /dev/null +++ b/fudge.ss @@ -0,0 +1,140 @@ +(import (scheme base) + (scheme file) + (scheme write) + (scheme char)) + +(define-syntax import-scheme + (syntax-rules () + ((_ module ...) + (import (scheme module) ...)))) + +(define keywords + '("true" "false" "struct" "enum" "if" "then" "else" "type" "let")) + +(define keyword? + (lambda (word) + (member word keywords))) + +(define get-word-string + (lambda (file) + (let ((c (peek-char file))) + (cond + ((eof-object? c) "") + ((char-alphabetic? c) + (read-char file) + (string-append (string c) (get-word file))) + (else ""))))) + +(define get-word + (lambda (file) + (let ((word (get-word-string file))) + (if (keyword? word) + (string->symbol word) + word)))) + +(define char->digit + (lambda (c) + (- (char->integer c) (char->integer #\0)))) + +; get-number supports only nonnegative integers. +(define get-number + (lambda (file) + (let f ((total 0)) + (let ((c (peek-char file))) + (cond + ((eof-object? c) total) + ((char-numeric? c) + (read-char file) + (f (+ (* total 10) (char->digit c)))) + (else total)))))) + +(define get-token + (lambda (file) + (let ((c (peek-char file))) + (cond + ((eof-object? c) 'end-of-file) + ((char-whitespace? c) + (read-char file) + (get-token file)) + ((char-alphabetic? c) + (get-word file)) + ((char-numeric? c) + (get-number file)) + ((eq? c #\+) (read-char file) '+) + ((eq? c #\-) (read-char file) '-) + ((eq? c #\*) (read-char file) '*) + ((eq? c #\/) (read-char file) '/) + ((eq? c #\=) (read-char file) '=) + ((eq? c #\() (read-char file) 'left-parenthesis) + ((eq? c #\)) (read-char file) 'right-parenthesis) + ((eq? c #\{) (read-char file) 'left-brace) + ((eq? c #\}) (read-char file) 'right-brace) + ((eq? c #\;) (read-char file) 'semicolon) + ((eq? c #\:) (read-char file) 'colon) + (else (error 'get-token "Bad character" c)))))) + +(define get-tokens + (lambda (file) + (let ((token (get-token file))) + (if (eq? token 'end-of-file) + '() + (cons token (get-tokens file)))))) + +(define tokenize + (lambda (filename) + (let ((file (open-input-file filename))) + (get-tokens file)))) + +(define test-lexer-fail + (lambda (input want got) + (display "text-lexer-fail: input=") + (write input) + (display "; want: ") + (write want) + (display "; got: ") + (write got) + (display ".") + (newline))) + + +(define test-lexer-success + (lambda (input got) + (display "text-lexer-success: input=") + (write input) + (display "; got: ") + (write got) + (display ".") + (newline))) + +(define test-lexer-fail-exception + (lambda (input x) + (display "test-lexer-fail: input ") + (write input) + (display " throws ") + (write (error-object-message x)) + (display ".") + (newline))) + +(define test-lexer + (lambda (input want) + (let ((port (open-input-string input))) + (call/cc + (lambda (i-got-exception) + (with-exception-handler + (lambda (x) + (test-lexer-fail-exception input x) + (i-got-exception x)) + (lambda () + (let ((got (get-tokens port))) + (if (equal? got want) + (test-lexer-success input got) + (test-lexer-fail input want got)))))))))) + +(test-lexer "hello world" '("hello" "world")) +(test-lexer "+ * / - = " '(+ * / - =)) +(test-lexer "( ) { }" '(left-parenthesis right-parenthesis left-brace right-brace)) +(test-lexer "true false" '(true false)) +(test-lexer "if then else" '(if then else)) +(test-lexer ": ;" '(colon semicolon)) +(test-lexer "identifier = 14" '("identifier" = 14)) +(test-lexer "" '())