1 /* subr.c -*- mode:c; coding:utf-8; -*-
2 *
3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com>
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 *
9 * 1. Redistributions of source code must retain the above copyright
10 * notice, this list of conditions and the following disclaimer.
11 *
12 * 2. Redistributions in binary form must reproduce the above copyright
13 * notice, this list of conditions and the following disclaimer in the
14 * documentation and/or other materials provided with the distribution.
15 *
16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
27 *
28 * $Id: $
29 */
30 #define LIBSAGITTARIUS_BODY
31 #include "sagittarius/private/subr.h"
32 #include "sagittarius/private/error.h"
33 #include "sagittarius/private/symbol.h"
34 #include "sagittarius/private/pair.h"
35 #include "sagittarius/private/port.h"
36 #include "sagittarius/private/generic.h"
37 #include "sagittarius/private/writer.h"
38 #include "sagittarius/private/vm.h"
39
proc_print(SgObject obj,SgPort * port,SgWriteContext * ctx)40 static void proc_print(SgObject obj, SgPort *port, SgWriteContext *ctx)
41 {
42 if (SG_PROCEDURE_TYPE(obj) == SG_PROC_SUBR)
43 Sg_Putuz(port, UC("#<subr "));
44 else if (SG_PROCEDURE_TYPE(obj) == SG_PROC_CLOSURE)
45 Sg_Putuz(port, UC("#<closure "));
46 /* well should not be here but in case. */
47 else if (SG_PROCEDURE_TYPE(obj) == SG_PROC_GENERIC)
48 Sg_Putuz(port, UC("#<generic "));
49 else if (SG_PROCEDURE_TYPE(obj) == SG_PROC_METHOD)
50 Sg_Putuz(port, UC("#<method "));
51 else if (SG_PROCEDURE_TYPE(obj) == SG_PROC_NEXT_METHOD)
52 Sg_Putuz(port, UC("#<next-method "));
53 Sg_Write(SG_PROCEDURE_NAME(obj), port, SG_WRITE_DISPLAY);
54
55 Sg_Printf(port, UC(" %d:%d"),
56 SG_PROCEDURE_REQUIRED(obj), SG_PROCEDURE_OPTIONAL(obj));
57
58 Sg_Putc(port, '>');
59 }
60 SG_DEFINE_BUILTIN_CLASS_SIMPLE(Sg_ProcedureClass, proc_print);
61
make_subr(int req,int opt,SgObject info)62 static SgSubr* make_subr(int req, int opt, SgObject info)
63 {
64 SgSubr *s = SG_NEW(SgSubr);
65 SG_SET_CLASS(s, SG_CLASS_PROCEDURE);
66 SG_PROCEDURE_INIT(s, req, opt, SG_PROC_SUBR, info);
67 return s;
68 }
69
Sg_MakeSubr(SgSubrProc proc,void * data,int required,int optional,SgObject info)70 SgObject Sg_MakeSubr(SgSubrProc proc, void *data, int required, int optional,
71 SgObject info)
72 {
73 SgSubr *s = make_subr(required, optional, info);
74 s->func = proc;
75 s->data = data;
76 return SG_OBJ(s);
77 }
78
Sg_MakeSubrFull(SgSubrProc proc,void * data,int required,int optional,SgObject info,int trans)79 SgObject Sg_MakeSubrFull(SgSubrProc proc, void *data, int required,
80 int optional, SgObject info, int trans)
81 {
82 SgSubr *s = make_subr(required, optional, info);
83 s->func = proc;
84 s->data = data;
85 /* SG_PROCEDURE_TRANSPARENT(s) = trans; */
86 return SG_OBJ(s);
87 }
88
89 static SgObject theNullProc = SG_NIL;
null_proc(SgObject * args,int argc,void * data)90 static SgObject null_proc(SgObject *args, int argc, void *data)
91 {
92 return SG_UNDEF;
93 }
94
Sg_NullProc()95 SgObject Sg_NullProc()
96 {
97 if (SG_NULLP(theNullProc)) {
98 theNullProc = Sg_MakeSubrFull(null_proc, NULL, 0, 1, SG_INTERN("nullproc"),
99 SG_PROC_TRANSPARENT);
100 }
101 return SG_OBJ(theNullProc);
102 }
103
104 /* for SRFI-17 */
Sg_SetterSet(SgProcedure * proc,SgProcedure * setter,int lock)105 SgObject Sg_SetterSet(SgProcedure *proc, SgProcedure *setter, int lock)
106 {
107 if (proc->locked) {
108 Sg_Error(UC("can't change the locked setter of procedure %S"), proc);
109 }
110 proc->setter = SG_OBJ(setter);
111 proc->locked = lock;
112 return SG_OBJ(proc);
113 }
114
object_setter(SgObject * args,int argc,void * data)115 static SgObject object_setter(SgObject *args, int argc, void *data)
116 {
117 ASSERT(argc == 1);
118 return Sg_VMApply(SG_OBJ(&Sg_GenericObjectSetter),
119 Sg_Cons(SG_OBJ(data), args[0]));
120 }
121
Sg_Setter(SgObject proc)122 SgObject Sg_Setter(SgObject proc)
123 {
124 if (SG_PROCEDUREP(proc)) {
125 return SG_PROCEDURE_SETTER(proc);
126 } else {
127 return Sg_MakeSubr(object_setter, (void*)proc, 0, 1,
128 SG_MAKE_STRING("object-setter"));
129 }
130 }
131
Sg_HasSetter(SgObject proc)132 int Sg_HasSetter(SgObject proc)
133 {
134 if (SG_PROCEDUREP(proc)) {
135 return !SG_FALSEP(SG_PROCEDURE_SETTER(proc));
136 } else {
137 /* setter of object-apply is used */
138 return TRUE;
139 }
140 }
141