M lib/scopes/compiler/Id.sc +106 -10
@@ 22,9 22,53 @@
```
using import print hash switcher
-from (import spicetools) let canonical-typeset type-subset?
+from (import spicetools) let canonical-typeset
+
+# for Id types: true if the set of types in A is fully contained within B
+spice subset? (A B)
+ A as:= type
+ B as:= type
+ AT := '@ A 'Types...
+ BT := '@ B 'Types...
+ acount := 'argcount AT
+ bcount := 'argcount BT
+
+ if (acount > bcount)
+ return false
+ for i in (range acount)
+ a := ('getarg AT i) as type
+ contained? := for j in (range bcount)
+ b := ('getarg BT j) as type
+ if (a == b)
+ break true
+ else false
+ if (not contained?)
+ return false
+ return true
-subset? := type-subset?
+# for enums: true if the set of values in A is fully contained within B
+spice verify-enum-subset (A B)
+ A as:= type
+ B as:= type
+ AT := '@ A '__fields__
+ BT := '@ B '__fields__
+ acount := 'argcount AT
+ bcount := 'argcount BT
+
+ for i in (range acount)
+ a := ('getarg AT i) as type
+ a_idx := ('@ a 'Index) as u64
+ contained? := for j in (range bcount)
+ b := ('getarg BT j) as type
+ b_idx := ('@ b 'Index) as u64
+ if (a_idx == b_idx)
+ break true
+ else false
+ if (not contained?)
+ error
+ (repr "field" a "of type" A "not contained in" B) as string
+
+run-stage;
ID_STORAGE_TYPE := u64
ID_LIMIT := 0xffffffffffffff:u64
@@ 41,12 85,18 @@ type Id
\ < cls : ID_STORAGE_TYPE
KindType := kind-type
Kind := none
- 'define-symbol T 'Types...
+ parent-types... := static-if (cls == this-type)
+ 'define-symbol T 'Types...
+ pass;
+ else
+ verify-enum-subset cls.KindType kind-type
+ cls.AllTypes...
# create subtypes
direct-types... := va-map
inline (F)
name := F.Name
- ST := type (name as zarray) < T : ID_STORAGE_TYPE
+ tname := .. (nameof T) "." (name as zarray)
+ ST := type (do tname) < T : ID_STORAGE_TYPE
Kind := getattr kind-type name
'define-symbol ST 'Types... ST
'define-symbol T name ST
@@ 68,7 118,8 @@ type Id
key name ST
kind-type.__fields__
'define-symbol T 'Types...
- canonical-typeset direct-types...
+ canonical-typeset
+ (va-join parent-types...) direct-types...
# create subtypes
indirect-types... := va-map
inline (...)
@@ 93,6 144,8 @@ type Id
(va-join direct-types...) indirect-types...
T
+ subtype := __typecall
+
inline __typecall (cls ...)
static-if (cls == this-type)
__typecall cls ...
@@ 105,9 158,8 @@ type Id
# true if all types in cls are contained in T
@@ memo
inline subtype? (cls T)
- static-if (cls == T) true
- elseif ((superof cls) == T) true
- elseif ((superof cls) == (superof T))
+ static-if (cls <= T) true
+ elseif (cls <= (superof T))
subset? cls T
else false
@@ 262,6 314,21 @@ type Id
else
print (/dec id)
+# helper macro to copy fields from a different enum
+inline replicate-enum-tags (enum-type tag prefix)
+ prefixf := static-if (none? prefix)
+ inline (name) name
+ else
+ prefix as:= zarray
+ inline (name)
+ Symbol
+ .. prefix
+ name as zarray
+ va-map
+ inline (field)
+ tag (prefixf field.Name) Nothing field.Index
+ enum-type.__fields__
+
if main-module?
using import enum downcast
@@ 273,8 340,10 @@ if main-module?
Const
Global
+ ID := Id
+
# define an Id type from Kind
- Id := Id Kind
+ Id := ID Kind
# define abstract supersets
TopLevel = Id.Group 'Function 'Const 'Global
FirstClass = Id.Group 'TopLevel 'Expr
@@ 308,8 377,35 @@ if main-module?
default
assert false
+ # later extend the type
+ enum MoreKinds : u8
+ replicate-enum-tags Kind tag "Parent"
+ Value
+ List
+ Scope
+
+ static-assert ((storagecast MoreKinds.ParentFunction) == Kind.Function)
+ static-assert ((storagecast MoreKinds.Value) == 5)
+
+ Id2 := 'subtype Id MoreKinds
+
+ x := imply g Id2
+
+ print x
+
+ # downcast dispatch
+ downcast... id
+ case Global (x)
+ print "global" x
+ case Function (x)
+ print "function" x
+ default
+ assert false
+
+ ;
+
do
- let Id
+ let Id replicate-enum-tags
locals;
M lib/scopes/compiler/arcmem/String.sc +1 -1
@@ 426,7 426,7 @@ type String :: (~ (arc@ char))
inline append-from-arrayptr (self source count)
cls := typeof self
let dest = (& (append-slots self count))
- memcpy
+ arcmemcopyn
bitcast dest (mutable rawstring)
source as rawstring
count * (sizeof cls.ElementType)
M lib/scopes/compiler/arcmem/init.sc +1 -1
@@ 2393,7 2393,7 @@ inline popswap (a b)
""""Safely exchange reference a with the contents of b,
return the old contents of a.
T := typeof a
- static-if (T <= arc@)
+ static-if ((storageof T) <= arc@)
b := imply b T
a := bitcast& a voidstar
b := bitcast b voidstar
A => lib/scopes/compiler/pilot/DBParser.sc +254 -0
@@ 0,0 1,254 @@
+
+using import itertools switcher
+ compiler.basics
+ compiler.Parser
+ compiler.Lexer
+ compiler.MappedFile
+ compiler.Id
+ compiler.Table
+
+#using import struct print itertools Array switcher downcast hash
+#using import C.string
+#using import ...Parser .StringPool .Any
+#using import ...Lexer ...MappedFile compiler.arcmem
+
+enum IdKind : u8
+ Anchor
+ Symbol
+ String
+ List
+
+Id := Id IdKind
+ Listable = Id.Group 'Symbol 'String 'List
+
+ListItem := tuple
+ id = Id.Listable
+ anchor = Id.Anchor
+
+ListItems := Array ListItem
+
+from Parser let Kind
+
+struct ParserDB
+ let Id IdKind
+
+ filepath : String
+
+ anchor : RowIndexedTable
+ id = Id.Anchor
+ begin = usize
+ end = usize
+ line = u32
+ column = u32
+
+ string : RowIndexedTable
+ id = Id.String
+ data = String
+
+ symbol : RowIndexedTable
+ id = Id.Symbol
+ hash = hash
+ data = String
+
+ # find symbol by hash
+ idx_symbol_string : Map hash Id.Symbol
+
+ list : RowIndexedTable
+ id = Id.List
+ items = ListItems
+
+ inline symbol (self str)
+ H := hash str
+ try
+ copy ('get self.idx_symbol_string H)
+ else
+ sid := self.symbol
+ hash = H
+ data = str
+ 'set self.idx_symbol_string H sid
+ sid
+
+struct DBParser < Parser
+ db : ~arc@ ParserDB
+
+ stack : Array (tuple Id.List Id.Anchor)
+ str : String
+ str_anchor : Id.Anchor
+ str_kind : Kind
+
+ inline __typecall (cls filepath)
+ new db := ParserDB
+ filepath = filepath
+ tllist := db.list ()
+ noanc := db.anchor ()
+ local self := super-type.__typecall cls
+ db = &db
+ str_anchor = noanc
+ 'append self.stack
+ typeinit tllist noanc
+ deref self
+
+ inline finalize (self)
+ super-type.finalize self
+ lid := unpack (copy ('pop self.stack))
+ pass
+ share self.db
+ lid
+
+ inline error (self start end ...)
+ print2
+ /.. self.db.filepath ":" (/dec start.line) ":" (/dec start.column) ":"
+ ...
+ abort;
+
+ inline append-any (self item)
+ lid := ('last self.stack) @ 0
+ li := self.db.list @& lid
+ 'append li.items item
+ ;
+
+ inline begin-string (self cursor kind capacity)
+ self.str_anchor = self.db.anchor
+ begin = cursor.offset
+ end = cursor.offset
+ line = cursor.line
+ column = cursor.column
+ self.str_kind = kind
+ inline string-data (self ptr size)
+ 'append-from-arrayptr self.str ptr size
+ inline string-char (self ch)
+ 'append self.str ch
+ fn end-string (self end)
+ aid := copy self.str_anchor
+ anc := self.db.anchor @& aid
+ anc.end = end.offset
+ str := popswap self.str (String)
+ inline prefixed-const (prefix)
+ prefix := "type:" .. (prefix as zarray)
+ static-assert (constant? prefix)
+ imply
+ self.db.list
+ items = ListItems
+ ListItem
+ 'symbol @self.db prefix
+ aid
+ ListItem
+ self.db.string str
+ aid
+ Id.Listable
+ switcher sw
+ case 'String
+ imply (self.db.string str) Id.Listable
+ case 'Symbol
+ imply ('symbol @self.db str) Id.Listable
+ default
+ report "todo:" self.str_kind
+ assert false
+ va-map
+ inline (tag)
+ switcher+ sw
+ case tag
+ prefixed-const tag
+ 'i8
+ 'i16
+ 'i32
+ 'i64
+ 'i128
+ 'u8
+ 'u16
+ 'u32
+ 'u64
+ 'u128
+ 'char
+ 'usize
+ 'f32
+ 'f64
+ itemid := sw self.str_kind
+ 'append-any self (ListItem itemid aid)
+
+ inline begin-list (self cursor)
+ 'append self.stack
+ typeinit
+ self.db.list ()
+ self.db.anchor
+ begin = cursor.offset
+ end = cursor.offset
+ line = cursor.line
+ column = cursor.column
+ inline end-list (self end single-unwrap?)
+ lid aid := unpack ('pop self.stack)
+ item := label item
+ if single-unwrap?
+ li := self.db.list @ lid
+ if ((countof li.items) == 1)
+ # unwrap-single
+ merge item (copy (li.items @ 0))
+ anc := self.db.anchor @& aid
+ anc.end = end.offset
+ ListItem lid aid
+ 'append-any self item
+
+# returns @db, root list id
+fn... parse-buffer (filename : rawstring, cursor : Location,
+ ptr : rawstring, size : usize)
+ ->>
+ range (size + 1)
+ map
+ inline (i)
+ if (i == size)
+ 0:char
+ else
+ deref (ptr @ i)
+ tokenize
+ map
+ inline (token begin end)
+ pass token begin end
+ & (ptr @ begin.offset)
+ & (ptr @ end.offset)
+ stateful
+ inline ()
+ DBParser
+ 'from-rawstring String filename
+
+fn... parse-file (filename : rawstring)
+ f := try! MappedFile.open filename
+ parse-buffer filename (Location) ('data f)
+
+@if main-module?
+do
+ print "--- parsing"
+ s... := parse-file module-path
+ print "done."
+ print s...
+ ;
+#
+
+print
+ sugar-quote
+ do
+ ;
+ x
+ ;
+ a
+ ;;
+ b
+ ;;;
+ c
+ do
+ \ a b c
+ d
+ \ e f \
+ g h
+ i
+ \ j k \
+ 1
+ 2
+ ;
+ 1 2
+ print;print 1;; print
+ 2
+@endif
+
+#do
+ let STILParser parse-buffer parse-file
+ locals;
M lib/scopes/hash.sc +2 -2
@@ 682,7 682,7 @@ let hash-storage =
'set-symbols hash
- __hash = (inline (self) self)
+ __hash = (inline (self) (deref self))
__== = integer.__==
__!= = integer.__!=
__< = integer.__<
@@ 826,7 826,7 @@ let uhash-storage =
`(bitcast hash-chain uhash)
'set-symbols uhash
- __uhash = (inline (self) self)
+ __uhash = (inline (self) (deref self))
__hash = (inline (self) (bitcast (itrunc self u64) hash))
__== = integer.__==
__!= = integer.__!=
M lib/scopes/spicetools.sc +0 -22
@@ 143,26 143,4 @@ spice canonical-typeset (types...)
sc_argument_list_new count types
-# true if the set of types in A is fully contained within B
-spice type-subset? (A B)
- A as:= type
- B as:= type
- AT := '@ A 'Types...
- BT := '@ B 'Types...
- acount := 'argcount AT
- bcount := 'argcount BT
-
- if (acount > bcount)
- return false
- for i in (range acount)
- contained? := for j in (range bcount)
- a := ('getarg AT i) as type
- b := ('getarg BT j) as type
- if (a == b)
- break true
- else false
- if (not contained?)
- return false
- return true
-
locals;