Committing some unstaged

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
+

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)
+  (cond
-      #f
+    ; Error check on `compare` and `key`
-      (if (compare key (caar als))
+    ( (not (procedure? compare))
-          (cdr (car als))
+      (error "generic-assoc: Argument #1 expected to be procedure, but was not.") )
-          (generic-assoc compare key (cdr als)))))
+    ( (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))
+    (cond ( (not (equal? 'let (car vo)))
-       ,@(map cadr (cadr 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 (if (pair? pat) (if (pair? (cdr pat)) (equal? '... (cadr pat))
-        `(if (pair? ,name)
+                            #f) #f)
-             (if ,(construct-pattern-predicate `(car ,name)
+        (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)
+                                               literals)))
-                 #f)
+          (cond ( (if (equal? #t test) (equal? #t body) #f)
-             #f)
+                   `(pair? ,name))
-    'fuck ))))))
+                ( (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)))
+                     ,(cons 'quasiquote (cons (construct-result bindings result) '()))
-                        (begin (display "Mjerf: ")
-                               (display sefijoesfeji)
-                               (newline)
-                               (cons 'quasiquote (cons sefijoesfeji '()))))
                      )
                    ,(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)
 
 

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