aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog17
-rw-r--r--src/boot/ast.boot18
-rw-r--r--src/boot/parser.boot48
-rw-r--r--src/boot/strap/ast.clisp243
-rw-r--r--src/boot/strap/parser.clisp35
-rw-r--r--src/boot/strap/tokens.clisp12
-rw-r--r--src/boot/strap/translator.clisp24
-rw-r--r--src/boot/tokens.boot1
-rw-r--r--src/boot/translator.boot1
9 files changed, 339 insertions, 60 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index b9d767a1..ea883533 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,20 @@
+2012-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * boot/translator.boot (translateToplevel): Handle record structures.
+ * boot/tokens.boot: "with" is now a keyword in Boot.
+ * boot/parser.boot (bpSignature): The typing is required afte the
+ colong.
+ (bpFieldList): New.
+ (bpGlobalAccessors): Likewise.
+ (bpAccessorDefinitionList): Likewise.
+ (bpAccessorDefinition): Likewise.
+ (bpFieldSection): Likewise.
+ (bpSelectField): Likewise.
+ (bpRecord): Likewise.
+ (bpStruct): Use it to implement record structures.
+ * boot/ast.boot (%Ast): Add %Record and %AccessorDef.
+ (bfRecordDef): New.
+
2012-05-21 Gabriel Dos Reis <gdr@cse.tamu.edu>
* boot/ast.boot (needsPROG): Remove.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 467caa3f..b3c568b4 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -62,6 +62,8 @@ structure %Ast ==
%Namespace(%Symbol) -- namespace AxiomCore
%Import(%Ast) -- import module; import namespace foo
%ImportSignature(%Symbol,%Signature) -- import function declaration
+ %Record(%List,%List) -- Record(num: %Short, den: %Short)
+ %AccessorDef(%Symbol,%Ast) -- numerator == (.num)
%TypeAlias(%Head, %List) -- type alias definition
%Signature(%Symbol,%Mapping) -- op: S -> T
%Mapping(%Ast, %List) -- (S1, S2) -> T
@@ -1336,6 +1338,22 @@ bfDs n ==
bfEnum(t,csts) ==
['DEFTYPE,t,nil,backquote(['MEMBER,:csts],nil)]
+bfRecordDef(s,fields,accessors) ==
+ parms := [x for f in fields | f is ['%Signature,x,.]]
+ fun := makeSymbol strconc('"mk",symbolName s)
+ ctor := makeSymbol strconc('"MAKE-",symbolName s)
+ recDef := ["DEFSTRUCT",s,:[x for ['%Signature,x,.] in fields]]
+ ctorDef :=
+ args := [:[bfColonColon("KEYWORD",p),p] for p in parms]
+ ["DEFMACRO",fun,parms,["LIST",quote ctor,:args]]
+ accDefs :=
+ accessors = nil => nil
+ x := bfGenSymbol()
+ [["DEFMACRO",acc,[x],
+ ["LIST",quote makeSymbol strconc(symbolName s,'"-",symbolName f),x]]
+ for ['%AccessorDef,acc,f] in accessors]
+ [recDef,ctorDef,:accDefs]
+
bfHandlers(n,e,hs) == main(n,e,hs,nil) where
main(n,e,hs,xs) ==
hs = nil =>
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index 516b47de..e698c359 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2011, Gabriel Dos Reis.
+-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -495,7 +495,7 @@ bpTypeAliasDefition() ==
++ Signature:
++ Name COLON Mapping
bpSignature() ==
- bpName() and bpEqKey "COLON" and bpTyping()
+ bpName() and bpEqKey "COLON" and bpRequire function bpTyping
and bpPush %Signature(bpPop2(), bpPop1())
++ SimpleMapping:
@@ -1153,8 +1153,50 @@ bpStruct()==
bpEqKey "STRUCTURE" and
bpRequire function bpName and
(bpEqKey "DEF" or bpTrap()) and
- bpTypeList() and bpPush %Structure(bpPop2(),bpPop1())
+ (bpRecord() or bpTypeList()) and
+ bpPush %Structure(bpPop2(),bpPop1())
+++ Record:
+++ "Record" "(" FieldList ")"
+bpRecord() ==
+ s := bpState()
+ bpName() and bpPop1() is "Record" =>
+ (bpParenthesized function bpFieldList or bpTrap()) and
+ bpGlobalAccessors() and
+ bpPush %Record(bfUntuple bpPop2(),bpPop1())
+ bpRestore s
+ false
+
+++ FieldList:
+++ Signature
+++ Signature , FieldList
+bpFieldList() ==
+ bpTuple function bpSignature
+
+bpGlobalAccessors() ==
+ bpEqKey "WITH" =>
+ bpPileBracketed function bpAccessorDefinitionList or bpTrap()
+ bpPush nil
+
+bpAccessorDefinitionList() ==
+ bpListAndRecover function bpAccessorDefinition
+
+++ AccessorDefinition:
+++ Name DEF FieldSection
+bpAccessorDefinition() ==
+ bpRequire function bpName and
+ (bpEqKey "DEF" or bpTrap()) and
+ bpRequire function bpFieldSection and
+ bpPush %AccessorDef(bpPop2(),bpPop1())
+
+++ FieldSection:
+++ "(" DOT Name ")"
+bpFieldSection() ==
+ bpParenthesized function bpSelectField
+
+bpSelectField() ==
+ bpEqKey "DOT" and bpName()
+
bpTypeList() ==
bpPileBracketed function bpTypeItemList
or bpTypeItem() and bpPush [bpPop1()]
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 808755db..59f68b8c 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -27,114 +27,119 @@
(DEFUN |%ImportSignature| #1=(|bfVar#8| |bfVar#9|)
(CONS '|%ImportSignature| (LIST . #1#)))
-(DEFUN |%TypeAlias| #1=(|bfVar#10| |bfVar#11|)
+(DEFUN |%Record| #1=(|bfVar#10| |bfVar#11|) (CONS '|%Record| (LIST . #1#)))
+
+(DEFUN |%AccessorDef| #1=(|bfVar#12| |bfVar#13|)
+ (CONS '|%AccessorDef| (LIST . #1#)))
+
+(DEFUN |%TypeAlias| #1=(|bfVar#14| |bfVar#15|)
(CONS '|%TypeAlias| (LIST . #1#)))
-(DEFUN |%Signature| #1=(|bfVar#12| |bfVar#13|)
+(DEFUN |%Signature| #1=(|bfVar#16| |bfVar#17|)
(CONS '|%Signature| (LIST . #1#)))
-(DEFUN |%Mapping| #1=(|bfVar#14| |bfVar#15|) (CONS '|%Mapping| (LIST . #1#)))
+(DEFUN |%Mapping| #1=(|bfVar#18| |bfVar#19|) (CONS '|%Mapping| (LIST . #1#)))
-(DEFUN |%Forall| #1=(|bfVar#16| |bfVar#17|) (CONS '|%Forall| (LIST . #1#)))
+(DEFUN |%Forall| #1=(|bfVar#20| |bfVar#21|) (CONS '|%Forall| (LIST . #1#)))
-(DEFUN |%Dynamic| #1=(|bfVar#18|) (CONS '|%Dynamic| (LIST . #1#)))
+(DEFUN |%Dynamic| #1=(|bfVar#22|) (CONS '|%Dynamic| (LIST . #1#)))
-(DEFUN |%SuffixDot| #1=(|bfVar#19|) (CONS '|%SuffixDot| (LIST . #1#)))
+(DEFUN |%SuffixDot| #1=(|bfVar#23|) (CONS '|%SuffixDot| (LIST . #1#)))
-(DEFUN |%Quote| #1=(|bfVar#20|) (CONS '|%Quote| (LIST . #1#)))
+(DEFUN |%Quote| #1=(|bfVar#24|) (CONS '|%Quote| (LIST . #1#)))
-(DEFUN |%EqualPattern| #1=(|bfVar#21|) (CONS '|%EqualPattern| (LIST . #1#)))
+(DEFUN |%EqualPattern| #1=(|bfVar#25|) (CONS '|%EqualPattern| (LIST . #1#)))
-(DEFUN |%Colon| #1=(|bfVar#22|) (CONS '|%Colon| (LIST . #1#)))
+(DEFUN |%Colon| #1=(|bfVar#26|) (CONS '|%Colon| (LIST . #1#)))
-(DEFUN |%QualifiedName| #1=(|bfVar#23| |bfVar#24|)
+(DEFUN |%QualifiedName| #1=(|bfVar#27| |bfVar#28|)
(CONS '|%QualifiedName| (LIST . #1#)))
-(DEFUN |%DefaultValue| #1=(|bfVar#25| |bfVar#26|)
+(DEFUN |%DefaultValue| #1=(|bfVar#29| |bfVar#30|)
(CONS '|%DefaultValue| (LIST . #1#)))
-(DEFUN |%Key| #1=(|bfVar#27| |bfVar#28|) (CONS '|%Key| (LIST . #1#)))
+(DEFUN |%Key| #1=(|bfVar#31| |bfVar#32|) (CONS '|%Key| (LIST . #1#)))
-(DEFUN |%Bracket| #1=(|bfVar#29|) (CONS '|%Bracket| (LIST . #1#)))
+(DEFUN |%Bracket| #1=(|bfVar#33|) (CONS '|%Bracket| (LIST . #1#)))
-(DEFUN |%UnboundedSegment| #1=(|bfVar#30|)
+(DEFUN |%UnboundedSegment| #1=(|bfVar#34|)
(CONS '|%UnboundedSegment| (LIST . #1#)))
-(DEFUN |%BoundedSgement| #1=(|bfVar#31| |bfVar#32|)
+(DEFUN |%BoundedSgement| #1=(|bfVar#35| |bfVar#36|)
(CONS '|%BoundedSgement| (LIST . #1#)))
-(DEFUN |%Tuple| #1=(|bfVar#33|) (CONS '|%Tuple| (LIST . #1#)))
+(DEFUN |%Tuple| #1=(|bfVar#37|) (CONS '|%Tuple| (LIST . #1#)))
-(DEFUN |%ColonAppend| #1=(|bfVar#34| |bfVar#35|)
+(DEFUN |%ColonAppend| #1=(|bfVar#38| |bfVar#39|)
(CONS '|%ColonAppend| (LIST . #1#)))
-(DEFUN |%Pretend| #1=(|bfVar#36| |bfVar#37|) (CONS '|%Pretend| (LIST . #1#)))
+(DEFUN |%Pretend| #1=(|bfVar#40| |bfVar#41|) (CONS '|%Pretend| (LIST . #1#)))
-(DEFUN |%Is| #1=(|bfVar#38| |bfVar#39|) (CONS '|%Is| (LIST . #1#)))
+(DEFUN |%Is| #1=(|bfVar#42| |bfVar#43|) (CONS '|%Is| (LIST . #1#)))
-(DEFUN |%Isnt| #1=(|bfVar#40| |bfVar#41|) (CONS '|%Isnt| (LIST . #1#)))
+(DEFUN |%Isnt| #1=(|bfVar#44| |bfVar#45|) (CONS '|%Isnt| (LIST . #1#)))
-(DEFUN |%Reduce| #1=(|bfVar#42| |bfVar#43|) (CONS '|%Reduce| (LIST . #1#)))
+(DEFUN |%Reduce| #1=(|bfVar#46| |bfVar#47|) (CONS '|%Reduce| (LIST . #1#)))
-(DEFUN |%PrefixExpr| #1=(|bfVar#44| |bfVar#45|)
+(DEFUN |%PrefixExpr| #1=(|bfVar#48| |bfVar#49|)
(CONS '|%PrefixExpr| (LIST . #1#)))
-(DEFUN |%Call| #1=(|bfVar#46| |bfVar#47|) (CONS '|%Call| (LIST . #1#)))
+(DEFUN |%Call| #1=(|bfVar#50| |bfVar#51|) (CONS '|%Call| (LIST . #1#)))
-(DEFUN |%InfixExpr| #1=(|bfVar#48| |bfVar#49| |bfVar#50|)
+(DEFUN |%InfixExpr| #1=(|bfVar#52| |bfVar#53| |bfVar#54|)
(CONS '|%InfixExpr| (LIST . #1#)))
-(DEFUN |%ConstantDefinition| #1=(|bfVar#51| |bfVar#52|)
+(DEFUN |%ConstantDefinition| #1=(|bfVar#55| |bfVar#56|)
(CONS '|%ConstantDefinition| (LIST . #1#)))
-(DEFUN |%Definition| #1=(|bfVar#53| |bfVar#54| |bfVar#55|)
+(DEFUN |%Definition| #1=(|bfVar#57| |bfVar#58| |bfVar#59|)
(CONS '|%Definition| (LIST . #1#)))
-(DEFUN |%Macro| #1=(|bfVar#56| |bfVar#57| |bfVar#58|)
+(DEFUN |%Macro| #1=(|bfVar#60| |bfVar#61| |bfVar#62|)
(CONS '|%Macro| (LIST . #1#)))
-(DEFUN |%Lambda| #1=(|bfVar#59| |bfVar#60|) (CONS '|%Lambda| (LIST . #1#)))
+(DEFUN |%Lambda| #1=(|bfVar#63| |bfVar#64|) (CONS '|%Lambda| (LIST . #1#)))
-(DEFUN |%SuchThat| #1=(|bfVar#61|) (CONS '|%SuchThat| (LIST . #1#)))
+(DEFUN |%SuchThat| #1=(|bfVar#65|) (CONS '|%SuchThat| (LIST . #1#)))
-(DEFUN |%Assignment| #1=(|bfVar#62| |bfVar#63|)
+(DEFUN |%Assignment| #1=(|bfVar#66| |bfVar#67|)
(CONS '|%Assignment| (LIST . #1#)))
-(DEFUN |%While| #1=(|bfVar#64|) (CONS '|%While| (LIST . #1#)))
+(DEFUN |%While| #1=(|bfVar#68|) (CONS '|%While| (LIST . #1#)))
-(DEFUN |%Until| #1=(|bfVar#65|) (CONS '|%Until| (LIST . #1#)))
+(DEFUN |%Until| #1=(|bfVar#69|) (CONS '|%Until| (LIST . #1#)))
-(DEFUN |%For| #1=(|bfVar#66| |bfVar#67| |bfVar#68|) (CONS '|%For| (LIST . #1#)))
+(DEFUN |%For| #1=(|bfVar#70| |bfVar#71| |bfVar#72|) (CONS '|%For| (LIST . #1#)))
-(DEFUN |%Implies| #1=(|bfVar#69| |bfVar#70|) (CONS '|%Implies| (LIST . #1#)))
+(DEFUN |%Implies| #1=(|bfVar#73| |bfVar#74|) (CONS '|%Implies| (LIST . #1#)))
-(DEFUN |%Iterators| #1=(|bfVar#71|) (CONS '|%Iterators| (LIST . #1#)))
+(DEFUN |%Iterators| #1=(|bfVar#75|) (CONS '|%Iterators| (LIST . #1#)))
-(DEFUN |%Cross| #1=(|bfVar#72|) (CONS '|%Cross| (LIST . #1#)))
+(DEFUN |%Cross| #1=(|bfVar#76|) (CONS '|%Cross| (LIST . #1#)))
-(DEFUN |%Repeat| #1=(|bfVar#73| |bfVar#74|) (CONS '|%Repeat| (LIST . #1#)))
+(DEFUN |%Repeat| #1=(|bfVar#77| |bfVar#78|) (CONS '|%Repeat| (LIST . #1#)))
-(DEFUN |%Pile| #1=(|bfVar#75|) (CONS '|%Pile| (LIST . #1#)))
+(DEFUN |%Pile| #1=(|bfVar#79|) (CONS '|%Pile| (LIST . #1#)))
-(DEFUN |%Append| #1=(|bfVar#76|) (CONS '|%Append| (LIST . #1#)))
+(DEFUN |%Append| #1=(|bfVar#80|) (CONS '|%Append| (LIST . #1#)))
-(DEFUN |%Case| #1=(|bfVar#77| |bfVar#78|) (CONS '|%Case| (LIST . #1#)))
+(DEFUN |%Case| #1=(|bfVar#81| |bfVar#82|) (CONS '|%Case| (LIST . #1#)))
-(DEFUN |%Return| #1=(|bfVar#79|) (CONS '|%Return| (LIST . #1#)))
+(DEFUN |%Return| #1=(|bfVar#83|) (CONS '|%Return| (LIST . #1#)))
-(DEFUN |%Leave| #1=(|bfVar#80|) (CONS '|%Leave| (LIST . #1#)))
+(DEFUN |%Leave| #1=(|bfVar#84|) (CONS '|%Leave| (LIST . #1#)))
-(DEFUN |%Throw| #1=(|bfVar#81|) (CONS '|%Throw| (LIST . #1#)))
+(DEFUN |%Throw| #1=(|bfVar#85|) (CONS '|%Throw| (LIST . #1#)))
-(DEFUN |%Catch| #1=(|bfVar#82| |bfVar#83|) (CONS '|%Catch| (LIST . #1#)))
+(DEFUN |%Catch| #1=(|bfVar#86| |bfVar#87|) (CONS '|%Catch| (LIST . #1#)))
-(DEFUN |%Finally| #1=(|bfVar#84|) (CONS '|%Finally| (LIST . #1#)))
+(DEFUN |%Finally| #1=(|bfVar#88|) (CONS '|%Finally| (LIST . #1#)))
-(DEFUN |%Try| #1=(|bfVar#85| |bfVar#86|) (CONS '|%Try| (LIST . #1#)))
+(DEFUN |%Try| #1=(|bfVar#89| |bfVar#90|) (CONS '|%Try| (LIST . #1#)))
-(DEFUN |%Where| #1=(|bfVar#87| |bfVar#88|) (CONS '|%Where| (LIST . #1#)))
+(DEFUN |%Where| #1=(|bfVar#91| |bfVar#92|) (CONS '|%Where| (LIST . #1#)))
-(DEFUN |%Structure| #1=(|bfVar#89| |bfVar#90|)
+(DEFUN |%Structure| #1=(|bfVar#93| |bfVar#94|)
(CONS '|%Structure| (LIST . #1#)))
(DEFPARAMETER |$inDefIS| NIL)
@@ -2467,6 +2472,148 @@
(DEFUN |bfEnum| (|t| |csts|)
(LIST 'DEFTYPE |t| NIL (|backquote| (CONS 'MEMBER |csts|) NIL)))
+(DEFUN |bfRecordDef| (|s| |fields| |accessors|)
+ (LET* (|accDefs|
+ |f|
+ |acc|
+ |ctorDef|
+ |args|
+ |recDef|
+ |ctor|
+ |fun|
+ |parms|
+ |ISTMP#2|
+ |x|
+ |ISTMP#1|)
+ (PROGN
+ (SETQ |parms|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |fields|)
+ (|f| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |f| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T
+ (AND (CONSP |f|) (EQ (CAR |f|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |f|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))))))
+ (COND
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |x| NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |fun| (INTERN (CONCAT "mk" (SYMBOL-NAME |s|))))
+ (SETQ |ctor| (INTERN (CONCAT "MAKE-" (SYMBOL-NAME |s|))))
+ (SETQ |recDef|
+ (CONS 'DEFSTRUCT
+ (CONS |s|
+ (LET ((|bfVar#6| NIL)
+ (|bfVar#7| NIL)
+ (|bfVar#5| |fields|)
+ (|bfVar#4| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#5|))
+ (PROGN (SETQ |bfVar#4| (CAR |bfVar#5|)) NIL))
+ (RETURN |bfVar#6|))
+ (T
+ (AND (CONSP |bfVar#4|)
+ (EQ (CAR |bfVar#4|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |bfVar#4|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (NULL (CDR |ISTMP#2|))))))
+ (COND
+ ((NULL |bfVar#6|)
+ (SETQ |bfVar#6| #2=(CONS |x| NIL))
+ (SETQ |bfVar#7| |bfVar#6|))
+ (T (RPLACD |bfVar#7| #2#)
+ (SETQ |bfVar#7| (CDR |bfVar#7|)))))))
+ (SETQ |bfVar#5| (CDR |bfVar#5|)))))))
+ (SETQ |ctorDef|
+ (PROGN
+ (SETQ |args|
+ (LET ((|bfVar#9| NIL)
+ (|bfVar#10| NIL)
+ (|bfVar#8| |parms|)
+ (|p| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#8|))
+ (PROGN (SETQ |p| (CAR |bfVar#8|)) NIL))
+ (RETURN |bfVar#9|))
+ (T
+ (LET ((|bfVar#11|
+ (LIST (|bfColonColon| 'KEYWORD |p|) |p|)))
+ (COND ((NULL |bfVar#11|) NIL)
+ ((NULL |bfVar#9|)
+ (SETQ |bfVar#9| |bfVar#11|)
+ (SETQ |bfVar#10| (|lastNode| |bfVar#9|)))
+ (T (RPLACD |bfVar#10| |bfVar#11|)
+ (SETQ |bfVar#10|
+ (|lastNode| |bfVar#10|)))))))
+ (SETQ |bfVar#8| (CDR |bfVar#8|)))))
+ (LIST 'DEFMACRO |fun| |parms|
+ (CONS 'LIST (CONS (|quote| |ctor|) |args|)))))
+ (SETQ |accDefs|
+ (COND ((NULL |accessors|) NIL)
+ (T (SETQ |x| (|bfGenSymbol|))
+ (LET ((|bfVar#14| NIL)
+ (|bfVar#15| NIL)
+ (|bfVar#13| |accessors|)
+ (|bfVar#12| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#13|))
+ (PROGN (SETQ |bfVar#12| (CAR |bfVar#13|)) NIL))
+ (RETURN |bfVar#14|))
+ (T
+ (AND (CONSP |bfVar#12|)
+ (EQ (CAR |bfVar#12|) '|%AccessorDef|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |bfVar#12|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |acc| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (NULL (CDR |ISTMP#2|))
+ (PROGN
+ (SETQ |f| (CAR |ISTMP#2|))
+ T)))))
+ (COND
+ ((NULL |bfVar#14|)
+ (SETQ |bfVar#14|
+ #3=(CONS
+ (LIST 'DEFMACRO |acc| (LIST |x|)
+ (LIST 'LIST
+ (|quote|
+ (INTERN
+ (CONCAT
+ (SYMBOL-NAME |s|)
+ "-"
+ (SYMBOL-NAME |f|))))
+ |x|))
+ NIL))
+ (SETQ |bfVar#15| |bfVar#14|))
+ (T (RPLACD |bfVar#15| #3#)
+ (SETQ |bfVar#15| (CDR |bfVar#15|)))))))
+ (SETQ |bfVar#13| (CDR |bfVar#13|)))))))
+ (CONS |recDef| (CONS |ctorDef| |accDefs|)))))
+
(DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL))
(DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 85db17da..fa16a127 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -462,7 +462,7 @@
(|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpSignature| ()
- (AND (|bpName|) (|bpEqKey| 'COLON) (|bpTyping|)
+ (AND (|bpName|) (|bpEqKey| 'COLON) (|bpRequire| #'|bpTyping|)
(|bpPush| (|%Signature| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpSimpleMapping| ()
@@ -1098,9 +1098,40 @@
(DEFUN |bpStruct| ()
(AND (|bpEqKey| 'STRUCTURE) (|bpRequire| #'|bpName|)
- (OR (|bpEqKey| 'DEF) (|bpTrap|)) (|bpTypeList|)
+ (OR (|bpEqKey| 'DEF) (|bpTrap|)) (OR (|bpRecord|) (|bpTypeList|))
(|bpPush| (|%Structure| (|bpPop2|) (|bpPop1|)))))
+(DEFUN |bpRecord| ()
+ (LET* (|s|)
+ (PROGN
+ (SETQ |s| (|bpState|))
+ (COND
+ ((AND (|bpName|) (EQ (|bpPop1|) '|Record|))
+ (AND (OR (|bpParenthesized| #'|bpFieldList|) (|bpTrap|))
+ (|bpGlobalAccessors|)
+ (|bpPush| (|%Record| (|bfUntuple| (|bpPop2|)) (|bpPop1|)))))
+ (T (|bpRestore| |s|) NIL)))))
+
+(DEFUN |bpFieldList| () (|bpTuple| #'|bpSignature|))
+
+(DEFUN |bpGlobalAccessors| ()
+ (COND
+ ((|bpEqKey| 'WITH)
+ (OR (|bpPileBracketed| #'|bpAccessorDefinitionList|) (|bpTrap|)))
+ (T (|bpPush| NIL))))
+
+(DEFUN |bpAccessorDefinitionList| ()
+ (|bpListAndRecover| #'|bpAccessorDefinition|))
+
+(DEFUN |bpAccessorDefinition| ()
+ (AND (|bpRequire| #'|bpName|) (OR (|bpEqKey| 'DEF) (|bpTrap|))
+ (|bpRequire| #'|bpFieldSection|)
+ (|bpPush| (|%AccessorDef| (|bpPop2|) (|bpPop1|)))))
+
+(DEFUN |bpFieldSection| () (|bpParenthesized| #'|bpSelectField|))
+
+(DEFUN |bpSelectField| () (AND (|bpEqKey| 'DOT) (|bpName|)))
+
(DEFUN |bpTypeList| ()
(OR (|bpPileBracketed| #'|bpTypeItemList|)
(AND (|bpTypeItem|) (|bpPush| (LIST (|bpPop1|))))))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 0ed1016a..d75c74a2 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -38,12 +38,12 @@
(LIST "or" 'OR) (LIST "rem" 'REM) (LIST "repeat" 'REPEAT)
(LIST "return" 'RETURN) (LIST "quo" 'QUO) (LIST "structure" 'STRUCTURE)
(LIST "then" 'THEN) (LIST "throw" 'THROW) (LIST "try" 'TRY)
- (LIST "until" 'UNTIL) (LIST "where" 'WHERE) (LIST "while" 'WHILE)
- (LIST "." 'DOT) (LIST ":" 'COLON) (LIST "::" 'COLON-COLON)
- (LIST "," 'COMMA) (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES)
- (LIST "**" 'POWER) (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS)
- (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
- (LIST "=" 'SHOEEQ) (LIST "~=" 'SHOENE) (LIST ".." 'SEG)
+ (LIST "until" 'UNTIL) (LIST "with" 'WITH) (LIST "where" 'WHERE)
+ (LIST "while" 'WHILE) (LIST "." 'DOT) (LIST ":" 'COLON)
+ (LIST "::" 'COLON-COLON) (LIST "," 'COMMA) (LIST ";" 'SEMICOLON)
+ (LIST "*" 'TIMES) (LIST "**" 'POWER) (LIST "/" 'SLASH) (LIST "+" 'PLUS)
+ (LIST "-" 'MINUS) (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE)
+ (LIST ">=" 'GE) (LIST "=" 'SHOEEQ) (LIST "~=" 'SHOENE) (LIST ".." 'SEG)
(LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW)
(LIST "<-" 'LARROW) (LIST ":=" 'BEC) (LIST "+->" 'GIVES)
(LIST "==" 'DEF) (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index a337d62e..37d7aa38 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -585,7 +585,17 @@
(T |x|)))))
(DEFUN |translateToplevel| (|b| |export?|)
- (LET* (|csts| |lhs| |t| |ISTMP#2| |sig| |ns| |n| |ISTMP#1| |xs|)
+ (LET* (|csts|
+ |accessors|
+ |fields|
+ |lhs|
+ |t|
+ |ISTMP#2|
+ |sig|
+ |ns|
+ |n|
+ |ISTMP#1|
+ |xs|)
(DECLARE
(SPECIAL |$activeNamespace| |$InteractiveMode| |$constantIdentifiers|
|$foreignsDefsForCLisp| |$currentModuleName|))
@@ -700,6 +710,18 @@
(|%Structure|
(LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
(COND
+ ((AND (CONSP |alts|) (EQ (CAR |alts|) '|%Record|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |alts|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |fields| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN
+ (SETQ |accessors| (CAR |ISTMP#2|))
+ T))))))
+ (|bfRecordDef| |t| |fields| |accessors|))
((AND (CONSP |alts|) (NULL (CDR |alts|))
(PROGN
(SETQ |ISTMP#1| (CAR |alts|))
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index cb3491df..b31eeec3 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -90,6 +90,7 @@ shoeKeyWords == [ _
['"throw", "THROW"], _
['"try", "TRY"], _
['"until", "UNTIL"], _
+ ['"with", "WITH" ], _
['"where", "WHERE"], _
['"while", "WHILE"], _
['".", "DOT"], _
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 6fca0944..79228477 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -480,6 +480,7 @@ translateToplevel(b,export?) ==
%Macro(op,args,body) => bfMDef(op,args,body)
%Structure(t,alts) =>
+ alts is ['%Record,fields,accessors] => bfRecordDef(t,fields,accessors)
alts is [['Enumeration,:csts]] => [bfEnum(t,csts)]
[bfCreateDef alt for alt in alts]
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 01:35:44 +0000