diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotBoundp.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotBoundp.java new file mode 100644 index 0000000..2055e9e --- /dev/null +++ b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotBoundp.java @@ -0,0 +1,79 @@ +package com.github.arvyy.islisp.functions; + +import com.github.arvyy.islisp.ISLISPContext; +import com.github.arvyy.islisp.exceptions.ISLISPError; +import com.github.arvyy.islisp.runtime.StandardClass; +import com.github.arvyy.islisp.runtime.StandardClassObject; +import com.github.arvyy.islisp.runtime.Symbol; +import com.oracle.truffle.api.CompilerDirectives; +import com.oracle.truffle.api.TruffleLanguage; +import com.oracle.truffle.api.dsl.Cached; +import com.oracle.truffle.api.dsl.Fallback; +import com.oracle.truffle.api.dsl.Specialization; +import com.oracle.truffle.api.frame.VirtualFrame; +import com.oracle.truffle.api.nodes.RootNode; +import com.oracle.truffle.api.staticobject.StaticProperty; + +/** + * Function instantiated for defclass slots with :boundp option. + */ +public abstract class ISLISPClassSlotBoundp extends RootNode { + + private final Symbol slot; + + /** + * Create slot boundp root node. + * + * @param slot slot's name + * @param language language reference + */ + public ISLISPClassSlotBoundp(Symbol slot, TruffleLanguage language) { + super(language); + this.slot = slot; + } + + @Override + public final Object execute(VirtualFrame frame) { + var obj = frame.getArguments()[1]; + return executeGeneric(obj); + } + + abstract Object executeGeneric(Object object); + + @Specialization(guards = "clsObject.clazz() == clazz", limit = "999") + Object doSpecialized( + StandardClassObject clsObject, + @Cached("clsObject.clazz()") StandardClass clazz, + @Cached("lookupProperty(clazz)") StaticProperty property + ) { + var ctx = ISLISPContext.get(this); + return property.getObject(clsObject.data()) == null + ? ctx.getNil() + : ctx.getT(); + } + + @Specialization + Object doUnspecialized(StandardClassObject clsObject) { + var property = lookupProperty(clsObject.clazz()); + var ctx = ISLISPContext.get(this); + return property.getObject(clsObject.data()) == null + ? ctx.getNil() + : ctx.getT(); + } + + @CompilerDirectives.TruffleBoundary + StaticProperty lookupProperty(StandardClass clazz) { + for (var classSlot: clazz.slots()) { + if (classSlot.name().equals(slot.identityReference())) { + return classSlot.property(); + } + } + return null; + } + + @Fallback + Object doFallback(Object o) { + throw new ISLISPError("Bad parameter", this); + } + +} diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotReader.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotReader.java index 8cc7eb2..18d4a6d 100644 --- a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotReader.java +++ b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotReader.java @@ -53,7 +53,9 @@ Object doSpecialized( @Specialization Object doUnspecialized(StandardClassObject clsObject) { - return lookupProperty(clsObject.clazz()).getObject(clsObject.data()); + return Objects.requireNonNullElse( + lookupProperty(clsObject.clazz()).getObject(clsObject.data()), + ISLISPContext.get(this).getNil()); } @CompilerDirectives.TruffleBoundary diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotWriter.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotWriter.java index c01a486..888e57f 100644 --- a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotWriter.java +++ b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPClassSlotWriter.java @@ -34,17 +34,17 @@ public ISLISPClassSlotWriter(Symbol slot, TruffleLanguage language) { @Override public final Object execute(VirtualFrame frame) { - var obj = frame.getArguments()[1]; - var value = frame.getArguments()[2]; - return executeGeneric(obj, value); + var value = frame.getArguments()[1]; + var obj = frame.getArguments()[2]; + return executeGeneric(value, obj); } - abstract Object executeGeneric(Object object, Object value); + abstract Object executeGeneric(Object value, Object classObject); @Specialization(guards = "clsObject.clazz() == clazz", limit = "999") Object doSpecialized( - StandardClassObject clsObject, Object value, + StandardClassObject clsObject, @Cached("clsObject.clazz()") StandardClass clazz, @Cached("lookupProperty(clazz)") StaticProperty property ) { @@ -53,7 +53,7 @@ Object doSpecialized( } @Specialization - Object doUnspecialized(StandardClassObject clsObject, Object value) { + Object doUnspecialized(Object value, StandardClassObject clsObject) { lookupProperty(clsObject.clazz()).setObject(clsObject.data(), value); return ISLISPContext.get(this).getNil(); } diff --git a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSignalCondition.java b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSignalCondition.java index 9312143..d55e230 100644 --- a/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSignalCondition.java +++ b/language/src/main/java/com/github/arvyy/islisp/functions/ISLISPSignalCondition.java @@ -69,10 +69,10 @@ public Object execute(VirtualFrame frame) { var conditionValue = frame.getArguments()[1]; var shouldFill = fillStacktrace.call(null, conditionValue); if (shouldFill != ctx.getNil()) { - setStacktrace.call(null, conditionValue, ISLISPCurrentStacktrace.currentStacktrace()); + setStacktrace.call(null, ISLISPCurrentStacktrace.currentStacktrace(), conditionValue); } var continuable = frame.getArguments()[2]; - setContinuable.call(null, conditionValue, continuable); + setContinuable.call(null, continuable, conditionValue); if (continuable != ctx.getNil()) { var handler = ctx.popHandler(); try { diff --git a/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPDefClassNode.java b/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPDefClassNode.java index 3fcf443..362f8cd 100644 --- a/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPDefClassNode.java +++ b/language/src/main/java/com/github/arvyy/islisp/nodes/ISLISPDefClassNode.java @@ -2,6 +2,7 @@ import com.github.arvyy.islisp.ISLISPContext; import com.github.arvyy.islisp.exceptions.ISLISPError; +import com.github.arvyy.islisp.functions.ISLISPClassSlotBoundpNodeGen; import com.github.arvyy.islisp.functions.ISLISPClassSlotReaderNodeGen; import com.github.arvyy.islisp.functions.ISLISPClassSlotWriterNodeGen; import com.github.arvyy.islisp.runtime.*; @@ -77,10 +78,38 @@ private ISLISPExpressionNode[] buildSlotFunctionNodes(TruffleLanguage languag ISLISPDefMethodNode.MethodQualifier.none, writer, false, - new Symbol[]{name, ISLISPContext.get(this).namedSymbol("")}, + new Symbol[]{ISLISPContext.get(this).namedSymbol(""), name}, false, ISLISPClassSlotWriterNodeGen.create(slot.getName(), language))); } + for (var accessor: slot.getAccessorName()) { + exprs.add(new ISLISPDefGenericNode(accessor, false, 1, false, null)); + exprs.add(new ISLISPDefMethodNode( + ISLISPDefMethodNode.MethodQualifier.none, + accessor, + false, + new Symbol[]{name}, + false, + ISLISPClassSlotReaderNodeGen.create(slot.getName(), language))); + exprs.add(new ISLISPDefGenericNode(accessor, true, 2, false, null)); + exprs.add(new ISLISPDefMethodNode( + ISLISPDefMethodNode.MethodQualifier.none, + accessor, + true, + new Symbol[]{ISLISPContext.get(this).namedSymbol(""), name}, + false, + ISLISPClassSlotWriterNodeGen.create(slot.getName(), language))); + } + for (var boundp: slot.getBoundpName()) { + exprs.add(new ISLISPDefGenericNode(boundp, false, 1, false, null)); + exprs.add(new ISLISPDefMethodNode( + ISLISPDefMethodNode.MethodQualifier.none, + boundp, + false, + new Symbol[]{name}, + false, + ISLISPClassSlotBoundpNodeGen.create(slot.getName(), language))); + } } return exprs.toArray(ISLISPExpressionNode[]::new); } diff --git a/tests/defclass.expect.txt b/tests/defclass.expect.txt index 549e5bb..826be63 100644 --- a/tests/defclass.expect.txt +++ b/tests/defclass.expect.txt @@ -2,3 +2,6 @@ 2 2 3 +4 +5 +6 diff --git a/tests/defclass.lisp b/tests/defclass.lisp index 0965575..4c46b7c 100644 --- a/tests/defclass.lisp +++ b/tests/defclass.lisp @@ -3,11 +3,11 @@ (format-char (standard-output) #\newline)) (defclass () - ((bar :reader get-bar :writer set-bar :initarg bar))) + ((bar :reader get-bar :writer set-bar :accessor bar :initarg bar :boundp bar-boundp))) (let ((f (create (class ) 'bar 1))) (print (get-bar f)) - (set-bar f 2) + (set-bar 2 f) (print (get-bar f))) ;; check inheritance @@ -18,6 +18,21 @@ ;; check initialize-object (defclass () ((bar3 :reader get-bar3 :writer set-bar3 :initarg bar))) (defmethod initialize-object ((f ) :rest args) - (set-bar3 f 3) + (set-bar3 3 f) (call-next-method)) -(print (get-bar3 (create (class ) 'bar 0))) \ No newline at end of file +(print (get-bar3 (create (class ) 'bar 0))) + +;; check accessor +(let ((obj (create (class )))) + (setf (bar obj) 4) + (print (bar obj))) + +;; check boundp +(let ((obj (create (class )))) + (if (bar-boundp obj) + (print 0) + (print 5)) + (setf (bar obj) 6) + (if (bar-boundp obj) + (print 6) + (print 0))) \ No newline at end of file