From 70d2c9f12cf8669c7e79ce102ee36805de03fce9 Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Thu, 19 Sep 2024 21:15:07 +0200 Subject: [PATCH] Committing some unstaged --- README.md | 12 +++ example.scm | 216 ++++++++++++++++++++++++++++++++++++++++++------ tigerscheme.tig | 25 +++++- 3 files changed, 227 insertions(+), 26 deletions(-) create mode 100755 README.md mode change 100644 => 100755 example.scm mode change 100644 => 100755 tigerscheme.tig diff --git a/README.md b/README.md new file mode 100755 index 0000000..043f61c --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ + +# Tiger Scheme + +Almost complete implementation of Scheme in Tiger. Performs +translation to bytecode, where after it executes the bytecode. + +As far as I remember, it doesn't support closures, and only some of +the macro forms. + +First change: Jan 5 2019 +Latest change: Dec 5 2019 + diff --git a/example.scm b/example.scm old mode 100644 new mode 100755 index 2fa6f09..7c42d9b --- a/example.scm +++ b/example.scm @@ -6,6 +6,10 @@ ; TODO: Fix below (define eq? eqv?) (define equal? eqv?) +(define (error str) + (begin (display "SCHEME ERROR: ") + (display str) + (display "\n"))) ; Lists @@ -53,12 +57,65 @@ (define (memv obj ls) (generic-member eqv? obj ls)) (define (member obj ls) (generic-member equal? obj ls)) +(define (cond-helper vo) + + ; Base case: + (if (null? vo) + '(if #f '()) ; This trick is used to ensure the result is identical to + ; failing a one-armed if-statement. + + ; Error: incorrect format + (if (not (pair? vo)) + (error "cond: Incorrect format") + + ; Else statement + (if (equal? 'else (caar vo)) + (car (cdr (car vo))) + + ; Normal statement + `(if ,(caar vo) + (begin ,@(cdr (car vo))) + ,(cond-helper (cdr vo))) + + )))) + +(define-syntax cond + (lambda (vo) + (if (not (equal? 'cond (car vo))) + (error "cond: Expected cond as keyword") + + (if (null? (cdr vo)) + (error "cond: cond must not be empty") + + (cond-helper (cdr vo)))))) + (define (generic-assoc compare key als) - (if (null? als) - #f - (if (compare key (caar als)) - (cdr (car als)) - (generic-assoc compare key (cdr als))))) + (cond + ; Error check on `compare` and `key` + ( (not (procedure? compare)) + (error "generic-assoc: Argument #1 expected to be procedure, but was not.") ) + ( (not (symbol? key)) + (error "generic-assoc: Argument #2 expected to be symbol, but was not.") ) + + ; Base case + ( (null? als) + #f ) + + ; Error check `als` structure + ( (if (not (pair? (car als))) #t (not (symbol? (caar als)))) + (error (string-append "generic-assoc: Argument #3 should be associative list, but was not" + "" + (datum->string als)))) + + ; Found the correct one + ( (compare key (caar als)) + (cdr (car als)) ) + + ; Otherwise: Continue along in the assoc list + ( else + (generic-assoc compare key (cdr als))) + + )) (define (assq obj ls) (generic-assoc eq? obj ls)) (define (assv obj ls) (generic-assoc eqv? obj ls)) @@ -365,10 +422,22 @@ (display "Test defining let using macroes:\n Expect: 23 82 105\n Gotten: ") +(define (let-names-helper vo) + (cond ( (not (pair? vo)) + (error "let: incorrect form: Not a pair!")) + ( (not (symbol? (car vo))) + (error "let: incorrect form: Not a symbol!")) + ( else + (car vo)))) + (define-syntax let (lambda (vo) - `( (lambda ,(map car (cadr vo)) ,(caddr vo)) - ,@(map cadr (cadr vo))))) + (cond ( (not (equal? 'let (car vo))) + (error "let: Incorrect form: Let was not the first keyword!")) + + ( else + `( (lambda ,(map let-names-helper (cadr vo)) ,(caddr vo)) + ,@(map cadr (cadr vo))))))) (let ((a 23) (b 82)) @@ -407,6 +476,21 @@ (header "Testing syntax-rules (move to macro once implemented)") +(define (syntax-rules-dots-traversal fn ls) + (if (null? ls) + '() + (if (not (pair? ls)) + #f + (if (fn (car ls)) + (let ((found (syntax-rules-dots-traversal fn (cdr ls)))) + (if found + `( ,(cons (car ls) (car found)) + ,(cdr found) ))) + + + + `(() ,ls) )))) + (define construct-pattern-predicate (lambda (name pat literals) (if (number? pat) @@ -417,29 +501,89 @@ (if (member pat literals) ; Is literal `(equal? ,name ',pat) + ; Or is variable binding #t) (if (null? pat) `(null? ,name) + (if (if (pair? pat) (if (pair? (cdr pat)) (equal? '... (cadr pat)) + #f) #f) + (let ((predicate (construct-pattern-predicate + 'vo3 + (car pat) + literals))) + (cond ; Very simple pattern + ( (if (equal? #t predicate) (null? (cddr pat)) #f) + #t ) + + ; Somewhat simple predicate + ( (equal? #t predicate) + (construct-pattern-predicate ''() + (cddr pat) + literals) + + ; Complex predicate / Default + ( else + `(let ((after (syntax-rules-dots-traversal + (lambda (vo3) ,predicate) + ,name))) + (if after + ,(construct-pattern-predicate '(cdr after) + (cddr pat) + literals) + #f)))))) + (if (pair? pat) - `(if (pair? ,name) - (if ,(construct-pattern-predicate `(car ,name) + (let (( test + (construct-pattern-predicate `(car ,name) (car pat) - literals) - ,(construct-pattern-predicate `(cdr ,name) + literals)) + ( body + (construct-pattern-predicate `(cdr ,name) (cdr pat) - literals) - #f) - #f) - 'fuck )))))) + literals))) + (cond ( (if (equal? #t test) (equal? #t body) #f) + `(pair? ,name)) + ( (equal? #t test) + `(if (pair? ,name) ,body #f)) + ( (equal? #t body) + `(if (pair? ,name) ,test #f)) + ( else + `(if (pair? ,name) (if ,test ,body #f) #f)) + )) + + 'fuck ))))))) (define (find-variable-bindings literals path pattern) ; Is symbol (if (if (symbol? pattern) (not (member pattern literals)) #f) `((,pattern ,path)) + + ; Is dots pair + ; TODO: Fix below, it is fucked. + (if (if (pair? pattern) + (if (pair? (cdr pattern)) + (equal? '... (cadr pattern)) #f) #f) + (let ( ( predicate + (construct-pattern-predicate + 'vo3 + (car pattern) + literals))) + (if (equal? predicate '#t) + `((,(car pattern) ,path)) + (error "Not implemented"))) + + ;`(let ((found (syntax-rules-dots-traversal + ;(lambda (vo3) ,predicate) + ;,pattern))) + ;(append + ;'((,(car pattern) ,path)) + ;,(find-variable-bindings literals + ;`(list-ref ,path (length found)) + ;(cddr pattern)))) ; Is pair (if (pair? pattern) @@ -449,14 +593,22 @@ ; Is anything else ; TODO: Vector patterns - '() ))) + '() )))) (define (construct-result bindings template) ; Is symbol (if (if (symbol? template) (assoc template bindings) #f) (cons 'unquote (cons template '())) - ; Is pair + ; Is dots pair + + (if (if (pair? template) + (if (pair? (cdr template)) + (equal? '... (cadr template)) #f) #f) + (cons (cons 'unquote-splicing (cons (car template) '())) + (construct-result bindings (cddr template))) + + ; Is normal pair (if (pair? template) (cons (construct-result bindings (car template)) @@ -465,26 +617,26 @@ ; Is anything else ; TODO: Vector patterns - template ))) + template )))) (define syntax-rules-rec (lambda (macro-name var-name literals rules) (if (null? rules) - 'doublefuck + '''doublefuck (let ((pattern (caar rules)) (result (cadar rules)) (bindings (find-variable-bindings literals var-name (caar rules))) ) + (begin (display "Derp: ") + (display bindings) + (newline) + (if (eqv? macro-name (car pattern)) `(if ,(construct-pattern-predicate var-name pattern literals ) (let ,bindings - ,(let ((sefijoesfeji (construct-result bindings result))) - (begin (display "Mjerf: ") - (display sefijoesfeji) - (newline) - (cons 'quasiquote (cons sefijoesfeji '())))) + ,(cons 'quasiquote (cons (construct-result bindings result) '())) ) ,(syntax-rules-rec macro-name var-name literals (cdr rules))) @@ -494,7 +646,7 @@ (display "\n\tBut one of them had ") (display (car pattern)) (newline))))))) - +) (define-syntax syntax-rules @@ -565,6 +717,20 @@ ( 0 . ,(+1 -1)) )) +(define-syntax derp + (syntax-rules () + ((derp a) a) + ((derp a b ...) (+ a (derp b ...))) +)) + +(test "Defining list using syntax-rules." + `( + ( 1 . ,(derp 1)) + ( 6 . ,(derp 6)) + ( 9 . ,(derp 4 5)) + ( 3 . ,(derp 1 1 1)) + )) + (exit) diff --git a/tigerscheme.tig b/tigerscheme.tig old mode 100644 new mode 100755 index 992f045..da3b28a --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -1342,6 +1342,12 @@ let /* Booleans */ ; app(OPCODE_NUMEQ, 0, "") ; app(OPCODE_RET, 1, "") + ; stdfun("procedure?") + ; app(OPCODE_TYPEOF, 0, "") + ; app2(OPCODE_PUSH, int_val(type_closure)) + ; app(OPCODE_NUMEQ, 0, "") + ; app(OPCODE_RET, 1, "") + ; std_insns @@ -1866,6 +1872,8 @@ let /* Booleans */ * unquote-splicing outside of quasiquote */ else if ast.typ = type_symbol & (ast.val_s = "unquote" | ast.val_s = "unquote-splicing") + | ast.typ = type_pair + & (ast.val_car.val_s = "unquote" | ast.val_car.val_s = "unquote-splicing") then ( compile_error(concat5( "Attempting to use \"" , ast.val_s , "\" outside of a quasiquote! It may be some misplaced brackets." @@ -2084,7 +2092,22 @@ let /* Booleans */ ; insns end - /* Call expressions */ + /* CAR or CDR expressions */ + else if ASSUME_NO_OVERWRITE_STDLIB + & ast.val_car.typ = type_symbol + & ast.val_cdr.typ = type_pair + & ast.val_cdr.val_cdr.typ = type_nil + & (ast.val_car.val_s = "car" | ast.val_car.val_s = "cdr") + + then let var insns := compile_rec(ast.val_cdr.val_car, false, type_any) + var opcode := if ast.val_car.val_s = "car" + then OPCODE_CAR + else OPCODE_CDR + in app_insn(insns, opcode, 0, "", ast.pos_l, ast.pos_r) + ; tail_position(insns, can_tail_call, ast.pos_l, ast.pos_r) + ; insns + end + else let var num_args := 0 var args_insns := vm_insn_list { first = nil, last = nil } var ast_iter := ast.val_cdr