~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/symbol.d

• browse files at revision 6
• compare with another revision
• download diff
• download tarball
• view history from revision 6

Show diffs side-by-side

added

removed

src/c/symbol.d

24

24

cl_object

25

25

cl_make_symbol(cl_object str)

26

26

{

27

 

        assert_type_string(str);

28

 

        str = si_copy_to_simple_base_string(str);

29

 

        @(return make_symbol(str))

30

 

}

31

 

 

32

 

cl_object

33

 

make_symbol(cl_object st)

34

 

{

35

27

        cl_object x;

36

 

 

 

28

 AGAIN:

 

29

        /* INV: In several places it is assumed that we copy the string! */

 

30

        switch (type_of(str)) {

 

31

#ifdef ECL_UNICODE

 

32

        case t_string:

 

33

                if (!ecl_fits_in_base_string(str)) {

 

34

                        str = cl_copy_seq(str);

 

35

                } else {

 

36

                        str = si_copy_to_simple_base_string(str);

 

37

                }

 

38

                break;

 

39

#endif

 

40

        case t_base_string:

 

41

                str = si_copy_to_simple_base_string(str);

 

42

                break;

 

43

        default:

 

44

                str = ecl_type_error(@'make-symbol',"name",str,@'string');

 

45

                goto AGAIN;

 

46

        }

37

47

        x = cl_alloc_object(t_symbol);

38

 

        /* FIXME! Should we copy? */

39

 

        x->symbol.name = si_copy_to_simple_base_string(st);

 

48

        x->symbol.name = str;

40

49

        x->symbol.dynamic = 0;

41

50

        ECL_SET(x,OBJNULL);

42

51

        SYM_FUN(x) = Cnil;

45

54

        x->symbol.stype = stp_ordinary;

46

55

        x->symbol.mflag = FALSE;

47

56

        x->symbol.isform = FALSE;

48

 

        return(x);

 

57

        @(return x)

49

58

}

50

59

 

51

60

/*

52

 

        Make_keyword(s) makes a keyword from C string s.

 

61

        ecl_make_keyword(s) makes a keyword from C string s.

53

62

*/

54

63

cl_object

55

 

make_keyword(const char *s)

 

64

ecl_make_keyword(const char *s)

56

65

{

57

 

        cl_object x = _intern(s, cl_core.keyword_package);

58

 

        /* cl_export(x, keyword_package); this is implicit in intern() */

 

66

        cl_object x = _ecl_intern(s, cl_core.keyword_package);

 

67

        /* cl_export(x, keyword_package); this is implicit in ecl_intern() */

59

68

        return x;

60

69

}

61

70

 

62

71

cl_object

63

 

symbol_value(cl_object s)

 

72

ecl_symbol_value(cl_object s)

64

73

{

65

74

        /* FIXME: Should we check symbol type? */

66

75

        cl_object value = SYM_VAL(s);

171

180

}

172

181

 

173

182

bool

174

 

keywordp(cl_object s)

 

183

ecl_keywordp(cl_object s)

175

184

{

176

185

        return (SYMBOLP(s) && s->symbol.hpack == cl_core.keyword_package);

177

186

}

178

187

 

179

188

@(defun get (sym indicator &optional deflt)

180

189

@

181

 

        assert_type_symbol(sym);

 

190

        sym = ecl_check_cl_type(@'get', sym, t_symbol);

182

191

        @(return ecl_getf(sym->symbol.plist, indicator, deflt))

183

192

@)

184

193

 

185

194

cl_object

186

195

cl_remprop(cl_object sym, cl_object prop)

187

196

{

188

 

        assert_type_symbol(sym);

 

197

        sym = ecl_check_cl_type(@'remprop', sym, t_symbol);

189

198

        @(return (remf(&sym->symbol.plist, prop)? Ct: Cnil))

190

199

}

191

200

 

192

201

cl_object

193

202

cl_symbol_plist(cl_object sym)

194

203

{

195

 

        assert_type_symbol(sym);

 

204

        sym = ecl_check_cl_type(@'symbol-plist', sym, t_symbol);

196

205

        @(return sym->symbol.plist)

197

206

}

198

207

 

213

222

                cl_object cdr_l = CDR(l);

214

223

                if (!CONSP(cdr_l))

215

224

                        break;

216

 

                if (member_eq(CAR(l), indicator_list))

 

225

                if (ecl_member_eq(CAR(l), indicator_list))

217

226

                        @(return CAR(l) CADR(l) l)

218

227

                l = CDR(cdr_l);

219

228

        }

225

234

cl_object

226

235

cl_symbol_name(cl_object x)

227

236

{

228

 

        assert_type_symbol(x);

 

237

        x = ecl_check_cl_type(@'symbol-name', x, t_symbol);

229

238

        @(return x->symbol.name)

230

239

}

231

240

 

232

241

@(defun copy_symbol (sym &optional cp &aux x)

233

242

@

234

 

        assert_type_symbol(sym);

235

 

        x = make_symbol(sym->symbol.name);

 

243

        x = ecl_check_cl_type(@'copy-symbol', x, t_symbol);

 

244

        x = cl_make_symbol(sym->symbol.name);

236

245

        if (Null(cp))

237

246

                @(return x)

238

247

        x->symbol.stype = sym->symbol.stype;

249

258

        cl_type t;

250

259

        cl_object counter, output;

251

260

        bool increment;

252

 

@

253

 

        t = type_of(prefix);

254

 

        if (t == t_base_string) {

 

261

@ {

 

262

 AGAIN:

 

263

        if (ecl_stringp(prefix)) {

255

264

                counter = SYM_VAL(@'*gensym-counter*');

256

265

                increment = 1;

257

 

        } else if (t == t_fixnum || t == t_bignum) {

 

266

        } else if ((t = type_of(prefix)) == t_fixnum || t == t_bignum) {

258

267

                counter = prefix;

259

268

                prefix = cl_core.gensym_prefix;

260

269

                increment = 0;

261

270

        } else {

262

 

                FEwrong_type_argument(cl_list(3, @'or', @'string', @'integer'),

263

 

                                      prefix);

 

271

                prefix = ecl_type_error(@'gensym',"prefix",prefix,

 

272

                                        cl_list(3, @'or', @'string', @'integer'));

 

273

                goto AGAIN;

264

274

        }

265

275

        output = ecl_make_string_output_stream(64);

266

276

        bds_bind(@'*print-base*', MAKE_FIXNUM(10));

267

277

        bds_bind(@'*print-radix*', Cnil);

268

 

        princ(prefix, output);

269

 

        princ(counter, output);

 

278

        ecl_princ(prefix, output);

 

279

        ecl_princ(counter, output);

270

280

        bds_unwind_n(2);

271

 

        output = make_symbol(cl_get_output_stream_string(output));

 

281

        output = cl_make_symbol(cl_get_output_stream_string(output));

272

282

        if (increment)

273

 

                ECL_SETQ(@'*gensym-counter*',one_plus(counter));

274

 

        @(return output)

275

 

@)

 

283

                ECL_SETQ(@'*gensym-counter*',ecl_one_plus(counter));

 

284

        @(return output);

 

285

} @)

276

286

 

277

 

@(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack current_package()))

 

287

@(defun gentemp (&optional (prefix cl_core.gentemp_prefix) (pack ecl_current_package()))

278

288

        cl_object output, s;

279

289

        int intern_flag;

280

290

@

281

 

        assert_type_base_string(prefix);

 

291

        prefix = ecl_check_type_string(@'gentemp', prefix);

282

292

        pack = si_coerce_to_package(pack);

283

293

ONCE_MORE:

284

294

        output = ecl_make_string_output_stream(64);

285

295

        bds_bind(@'*print-base*', MAKE_FIXNUM(10));

286

296

        bds_bind(@'*print-radix*', Cnil);

287

 

        princ(prefix, output);

288

 

        princ(cl_core.gentemp_counter, output);

 

297

        ecl_princ(prefix, output);

 

298

        ecl_princ(cl_core.gentemp_counter, output);

289

299

        bds_unwind_n(2);

290

 

        cl_core.gentemp_counter = one_plus(cl_core.gentemp_counter);

291

 

        s = intern(cl_get_output_stream_string(output), pack, &intern_flag);

 

300

        cl_core.gentemp_counter = ecl_one_plus(cl_core.gentemp_counter);

 

301

        s = ecl_intern(cl_get_output_stream_string(output), pack, &intern_flag);

292

302

        if (intern_flag != 0)

293

303

                goto ONCE_MORE;

294

304

        @(return s)

297

307

cl_object

298

308

cl_symbol_package(cl_object sym)

299

309

{

300

 

        assert_type_symbol(sym);

 

310

        sym = ecl_check_cl_type(@'symbol-package', sym, t_symbol);

301

311

        @(return sym->symbol.hpack)

302

312

}

303

313

 

304

314

cl_object

305

315

cl_keywordp(cl_object sym)

306

316

{

307

 

        @(return ((SYMBOLP(sym) && keywordp(sym))? Ct: Cnil))

 

317

        @(return ((SYMBOLP(sym) && ecl_keywordp(sym))? Ct: Cnil))

308

318

}

309

319

 

310

320

/*

328

338

cl_object

329

339

si_set_symbol_plist(cl_object sym, cl_object plist)

330

340

{

331

 

        assert_type_symbol(sym);

 

341

        sym = ecl_check_cl_type(@'si::set-symbol-plist', sym, t_symbol);

332

342

        sym->symbol.plist = plist;

333

343

        @(return plist)

334

344

}

336

346

cl_object

337

347

si_putprop(cl_object sym, cl_object value, cl_object indicator)

338

348

{

339

 

        assert_type_symbol(sym);

 

349

        sym = ecl_check_cl_type(@'si::putprop', sym, t_symbol);

340

350

        sym->symbol.plist = si_put_f(sym->symbol.plist, value, indicator);

341

351

        @(return value)

342

352

}

355

365

cl_object

356

366

@si::*make_special(cl_object sym)

357

367

{

358

 

        assert_type_symbol(sym);

 

368

        sym = ecl_check_cl_type(@'defvar', sym, t_symbol);

359

369

        if ((enum ecl_stype)sym->symbol.stype == stp_constant)

360

370

                FEerror("~S is a constant.", 1, sym);

361

371

        sym->symbol.stype = (short)stp_special;

366

376

cl_object

367

377

@si::*make_constant(cl_object sym, cl_object val)

368

378

{

369

 

        assert_type_symbol(sym);

 

379

        sym = ecl_check_cl_type(@'defconstant', sym, t_symbol);

370

380

        if ((enum ecl_stype)sym->symbol.stype == stp_special)

371

381

                FEerror(

372

382

                 "The argument ~S to DEFCONSTANT is a special variable.",

• Older »

Loggerhead is a web-based interface for Breezy
Version: 2.0.1