aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--driver.s28
-rw-r--r--example.txt38
-rw-r--r--snug-clean/src/MIPS/MIPS32.dcl1
-rw-r--r--snug-clean/src/MIPS/MIPS32.icl1
-rw-r--r--snug-clean/src/Snug/Compile.icl37
-rw-r--r--snug-clean/src/Snug/Compile/Simulate.dcl7
-rw-r--r--snug-clean/src/Snug/Parse.icl24
7 files changed, 114 insertions, 22 deletions
diff --git a/driver.s b/driver.s
index 44520b2..d717270 100644
--- a/driver.s
+++ b/driver.s
@@ -1,11 +1,21 @@
.data
+ .align 2
+heap:
+ .space 0x80000 # 512KiB
+
.align 1
_cINT:
.byte 0 # pointer arity
.byte 1 # basic value arity
.byte 0 # number of arguments that still have to be curried in
+ .align 1
+_cCHAR:
+ .byte 0 # pointer arity
+ .byte 1 # basic value arity
+ .byte 0 # number of arguments that still have to be curried in
+
.align 2
PRINTROOT:
.word _nroot
@@ -14,9 +24,6 @@ EVALROOT:
.word _nroot
.word 0 # to be filled in
- .align 2
-heap:
-
.text
main:
la $gp,heap
@@ -56,6 +63,8 @@ print_hnf:
lw $t0,($s1)
la $t1,_cINT
beq $t0,$t1,print_int
+ la $t1,_cCHAR
+ beq $t0,$t1,print_char
li $a0,'('
li $v0,11 # print_char
syscall
@@ -76,6 +85,19 @@ print_int:
b print_rewind
nop
+print_char:
+ li $a0,39 # '
+ li $v0,11 # print_char
+ syscall
+ lw $a0,4($s1)
+ li $v0,11 # print_char
+ syscall
+ li $a0,39 # '
+ li $v0,11 # print_char
+ syscall
+ b print_rewind
+ nop
+
print_rewind:
la $t5,PRINTROOT
beq $s0,$t5,print_rewind_root
diff --git a/example.txt b/example.txt
index 38041f0..26fc2d8 100644
--- a/example.txt
+++ b/example.txt
@@ -5,13 +5,6 @@
(Cons a (List a))))
(type String (List Char))
-(fun length ((xs : List a)) : Int
- (length_acc 0 xs))
-(fun length_acc ((n : Int) (xs : List a)) : Int
- (case xs (
- (Nil -> n)
- (Cons _ xs -> length_acc (+ n 1) xs))))
-
(data TypeIdent ((TI String)))
(data TypeVarIdent ((TVI String)))
(data ConstructorIdent ((CI String)))
@@ -39,7 +32,8 @@
(CaseAlternative Pattern Expression)))
(data Expression (
- (Ident SymbolIdent)
+ (BasicValue BasicValue)
+ (Symbol SymbolIdent)
(Case Expression (List CaseAlternative))
(ExpApp Expression Expression)))
@@ -60,12 +54,26 @@
(Cons (Tuple (Cons 'n' Nil) (Type (Cons 'I' (Cons 'n' (Cons 't' Nil)))))
(Cons (Tuple (Cons 'x' (Cons 's' Nil)) (TypeApp (Type (Cons 'L' (Cons 'i' (Cons 's' (Cons 't' Nil))))) (TypeVar (Cons 'a' Nil))))
Nil))
- (Case (Ident (Cons 'x' (Cons 's' Nil)))
- (Cons (CaseAlternative (ConstructorPattern (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil) (Ident (Cons 'n' Nil)))
- (Cons (CaseAlternative (ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons Wildcard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil))))
- Nil)))))
+ (Type (Cons 'I' (Cons 'n' (Cons 't' Nil))))
+ (Case (Symbol (Cons 'x' (Cons 's' Nil)))
+ (Cons (CaseAlternative
+ (ConstructorPattern (Cons 'N' (Cons 'i' (Cons 'l' Nil))) Nil)
+ (Symbol (Cons 'n' Nil)))
+ (Cons (CaseAlternative
+ (ConstructorPattern (Cons 'C' (Cons 'o' (Cons 'n' (Cons 's' Nil)))) (Cons Wildcard (Cons (IdentPattern (Cons 'x' (Cons 's' Nil))) Nil)))
+ (ExpApp (ExpApp (Symbol (Cons 'l' (Cons 'e' (Cons 'n' (Cons 'g' (Cons 't' (Cons 'h' (Cons '_' (Cons 'a' (Cons 'c' (Cons 'c' Nil))))))))))) (ExpApp (ExpApp (Cons '+' Nil) (Cons 'n' Nil)) (BasicValue (BVInt 1)))) (Cons 'x' (Cons 's' Nil))))
+ Nil)))))
+
+(#
+(fun length ((xs : List a)) : Int
+ (length_acc 0 xs))
+(fun length_acc ((n : Int) (xs : List a)) : Int
+ (case xs (
+ (Nil -> n)
+ (Cons _ xs -> length_acc (+ n 1) xs))))
+#)
-(fun testb () : Int
- 37)
+(fun testb ((x : Int) (y : Int)) : Int
+ (Tuple 37 'a'))
(fun test () : Int
- (testb))
+ (testb 37 42))
diff --git a/snug-clean/src/MIPS/MIPS32.dcl b/snug-clean/src/MIPS/MIPS32.dcl
index a2c85dc..6e5ff44 100644
--- a/snug-clean/src/MIPS/MIPS32.dcl
+++ b/snug-clean/src/MIPS/MIPS32.dcl
@@ -6,6 +6,7 @@ from StdOverloaded import class toString
= StartSection !String
| Align !Int
| Label !Label
+ | Global !Label
| Instr !Instruction
| RawByte !Int
| RawWord !Int
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
index 6e602be..ca5cbee 100644
--- a/snug-clean/src/MIPS/MIPS32.icl
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -9,6 +9,7 @@ where
toString (StartSection s) = "\t." +++ s
toString (Align i) = "\t.align\t" +++ toString i
toString (Label l) = l +++ ":"
+ toString (Global l) = "\t.globl\t" +++ l
toString (Instr i) = "\t" +++ toString i
toString (RawByte i) = "\t.byte\t" +++ toString i
toString (RawWord i) = "\t.word\t" +++ toString i
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 43f8a37..50119f3 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -65,6 +65,9 @@ gatherGlobals ns defs =
]
}
+lookupConstructor :: !Namespace !ConstructorIdent !Globals -> ?ConstructorDef
+lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors
+
lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo
lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions
@@ -77,6 +80,7 @@ compileDefinition ns globals (DataDef _ _ constructors) =
]
compileDefinition ns globals (FunDef id args ret expr) =
[ StartSection "text"
+ , Global label
// TODO: Ideally we would use the following here:
//, Align 1
//, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
@@ -87,10 +91,11 @@ compileDefinition ns globals (FunDef id args ret expr) =
(sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change
(length args << 8)) // arity
// instead... (end modification)
- , Label (functionLabel ns NodeEntry id)
+ , Label label
: map Instr (compileExpr ns globals locals expr)
]
where
+ label = functionLabel ns NodeEntry id
locals = 'Data.Map'.fromList
[ (id, Indirect FrontEvalPtr (offset*4))
\\ (id,_) <- args
@@ -99,12 +104,15 @@ where
compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
compileConstructor ns _ (ConstructorDef id args) =
- [ Align 1
- , Label (constructorLabel ns id)
+ [ Global label
+ , Align 1
+ , Label label
, RawByte (length args) // pointer arity
, RawByte 0 // basic value arity
, RawByte 0 // number of arguments still to be curried in
]
+where
+ label = constructorLabel ns id
compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
compileExpr ns globals locals expr = simulate $
@@ -127,6 +135,29 @@ simulator ns globals locals (Symbol id) = // TODO include locals
buildThunk (functionLabel ns NodeEntry id) 0
_ ->
abort "symbol with arity > 0\n" // TODO implement
+simulator ns globals locals expr=:(ExpApp _ _) =
+ case f of
+ Symbol id -> // TODO include locals
+ case lookupFunction ns id globals of
+ ?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up
+ ?Just info | info.arity == length args ->
+ mapM_ (simulator ns globals locals) args >>|
+ buildThunk (functionLabel ns NodeEntry id) info.arity
+ _ -> abort ("arity mismatch in application\n") // TODO implement
+ Constructor id ->
+ case lookupConstructor ns id globals of
+ ?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up
+ ?Just (ConstructorDef _ arg_types) | length arg_types == length args ->
+ mapM_ (simulator ns globals locals) args >>|
+ buildCons (constructorLabel ns id) (length args)
+ _ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement
+ _ -> // TODO
+ abort "unexpected lhs of function application\n"
+where
+ (f, args) = linearizeApp expr []
+
+ linearizeApp (ExpApp f x) xs = linearizeApp f [x:xs]
+ linearizeApp e xs = (e, xs)
simulator _ _ _ _ = // TODO
pushBasicValue (BVInt 0) >>|
buildCons (constructorLabel "" "INT") 1
diff --git a/snug-clean/src/Snug/Compile/Simulate.dcl b/snug-clean/src/Snug/Compile/Simulate.dcl
index 9b938d5..a36dc0d 100644
--- a/snug-clean/src/Snug/Compile/Simulate.dcl
+++ b/snug-clean/src/Snug/Compile/Simulate.dcl
@@ -18,9 +18,16 @@ from Snug.Syntax import :: BasicValue
simulate :: !(Simulator a) -> [Instruction]
+//* Build a constructor node with *n* arguments and push it to the stack.
buildCons :: !Label !Int -> Simulator ()
+//* Build a thunk node with *n* arguments and push it to the stack.
buildThunk :: !Label !Int -> Simulator ()
+//* Push a basic value to the stack.
pushBasicValue :: !BasicValue -> Simulator ()
+/**
+ * Overwrite the node currently under evaluation with an indirection to the
+ * node on top of the stack, and continue evaluating that node instead.
+ */
indirectAndEval :: Simulator ()
diff --git a/snug-clean/src/Snug/Parse.icl b/snug-clean/src/Snug/Parse.icl
index 63a9fda..75d9295 100644
--- a/snug-clean/src/Snug/Parse.icl
+++ b/snug-clean/src/Snug/Parse.icl
@@ -16,9 +16,11 @@ import Text.Parsers.Simple.Core
import Snug.Syntax
parseSnug :: ![Char] -> MaybeError String [Definition]
-parseSnug cs = case parse (many definition`) (lex cs) of
+parseSnug cs = case parse (many definition`) (filterComments (lex cs)) of
Left errors -> Error ('Text'.join "; " errors)
Right defs -> Ok defs
+where
+ filterComments tks = [t \\ t <- tks | not (t=:(TComment _))]
definition` :: Parser Token Definition
definition` = parenthesized def
@@ -146,6 +148,7 @@ nonEmpty p = p >>= \xs -> if (isEmpty xs) pFail (pure xs)
| TInt !Int
| TChar !Char
+ | TComment !String //* (# ... #)
| TError !Int !Int !String
instance == Token
@@ -161,6 +164,8 @@ where
(==) (TInt _) _ = False
(==) (TChar x) (TChar y) = x == y
(==) (TChar _) _ = False
+ (==) (TComment x) (TComment y) = x == y
+ (==) (TComment _) _ = False
(==) (TError _ _ _) _ = False
lex :: ![Char] -> [Token]
@@ -169,6 +174,23 @@ lex cs = lex` 0 0 cs
lex` :: !Int !Int ![Char] -> [Token]
lex` _ _ []
= []
+lex` line col ['(#':cs]
+ = stripComment line (col+2) cs 0 []
+where
+ stripComment line col ['#)':cs] 0 acc
+ = [TComment (toString (reverse acc)) : lex` line (col+2) cs]
+ stripComment line col ['(#':cs] n acc
+ = stripComment line (col+2) cs (n+1) ['#(':acc]
+ stripComment line col ['\r\n':cs] n acc
+ = stripComment (line+1) 0 cs n ['\n\r':acc]
+ stripComment line col ['\n\r':cs] n acc
+ = stripComment (line+1) 0 cs n ['\r\n':acc]
+ stripComment line col [c:cs] n acc
+ | c=='\n' || c=='\r'
+ = stripComment (line+1) 0 cs n [c:acc]
+ = stripComment line (col+1) cs n [c:acc]
+ stripComment line col [] _ _
+ = [TError line col "end of file while scanning comment"]
/* This alternative is for characters that can never be part of identifiers: */
lex` line col [c:cs]
| isJust mbToken
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 21:24:10 +0000