Jmaa/tiger-scheme
1
0
Fork 0
Code

Committing some unstaged

Browse Source
This commit is contained in:
Jon Michael Aanes 2024-09-19 21:15:07 +02:00
parent fcdcf72841
commit 70d2c9f12c
Signed by: Jmaa
SSH Key Fingerprint: SHA256:Ab0GfHGCblESJx7JRE4fj4bFy/KRpeLhi41y4pF3sNA
3 changed files with 227 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
README.md Executable file
View File

@ -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

216
example.scm Normal file → Executable file
View File

@ -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 (pair? pat)
`(if (pair? ,name)
(if ,(construct-pattern-predicate `(car ,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)
,(construct-pattern-predicate `(cdr ,name)
; 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)
(let (( test
(construct-pattern-predicate `(car ,name)
(car pat)
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)

25
tigerscheme.tig Normal file → Executable file
View File

@ -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