Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
abcl
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
abcl
abcl
Commits
2c9492a9
Commit
2c9492a9
authored
Feb 10, 2010
by
mevenson@1c010e3e-69d0-11dd-93a8-456734b0d56f
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Documentation updates and conversion to stack trace friendly Primitive declarations.
parent
9735baa6
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
219 additions
and
187 deletions
+219
-187
src/org/armedbear/lisp/Extensions.java
src/org/armedbear/lisp/Extensions.java
+219
-187
No files found.
src/org/armedbear/lisp/Extensions.java
View file @
2c9492a9
...
...
@@ -46,232 +46,264 @@ public final class Extensions
list
(
intern
(
"DEFAULT-ED-FUNCTION"
,
PACKAGE_SYS
)));
// ### truly-the value-type form => result*
private
static
final
SpecialOperator
TRULY_THE
=
new
SpecialOperator
(
"truly-the"
,
PACKAGE_EXT
,
true
,
"type value"
)
private
static
final
SpecialOperator
TRULY_THE
=
new
truly_the
();
private
static
class
truly_the
extends
SpecialOperator
{
truly_the
()
{
super
(
"truly-the"
,
PACKAGE_EXT
,
true
,
"type value"
);
}
@Override
public
LispObject
execute
(
LispObject
args
,
Environment
env
)
{
@Override
public
LispObject
execute
(
LispObject
args
,
Environment
env
)
{
if
(
args
.
length
()
!=
2
)
return
error
(
new
WrongNumberOfArgumentsException
(
this
));
return
eval
(
args
.
cadr
(),
env
,
LispThread
.
currentThread
());
}
};
if
(
args
.
length
()
!=
2
)
return
error
(
new
WrongNumberOfArgumentsException
(
this
));
return
eval
(
args
.
cadr
(),
env
,
LispThread
.
currentThread
());
}
}
// ### neq
private
static
final
Primitive
NEQ
=
new
Primitive
(
Symbol
.
NEQ
,
"obj1 obj2"
)
private
static
final
Primitive
NEQ
=
new
neq
();
private
static
class
neq
extends
Primitive
{
neq
()
{
super
(
Symbol
.
NEQ
,
"obj1 obj2"
);
}
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
return
first
!=
second
?
T
:
NIL
;
}
};
}
}
// ### memq item list => tail
private
static
final
Primitive
MEMQ
=
new
Primitive
(
Symbol
.
MEMQ
,
"item list"
)
private
static
final
Primitive
MEMQ
=
new
memq
();
private
static
class
memq
extends
Primitive
{
memq
()
{
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
while
(
list
instanceof
Cons
)
{
if
(
item
==
((
Cons
)
list
).
car
)
return
list
;
list
=
((
Cons
)
list
).
cdr
;
}
if
(
list
!=
NIL
)
type_error
(
list
,
Symbol
.
LIST
);
return
NIL
;
}
};
super
(
Symbol
.
MEMQ
,
"item list"
);
}
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
while
(
list
instanceof
Cons
)
{
if
(
item
==
((
Cons
)
list
).
car
)
return
list
;
list
=
((
Cons
)
list
).
cdr
;
}
if
(
list
!=
NIL
)
type_error
(
list
,
Symbol
.
LIST
);
return
NIL
;
}
}
// ### memql item list => tail
private
static
final
Primitive
MEMQL
=
new
Primitive
(
Symbol
.
MEMQL
,
"item list"
)
private
static
final
Primitive
MEMQL
=
new
memql
();
private
static
class
memql
extends
Primitive
{
memql
()
{
super
(
Symbol
.
MEMQL
,
"item list"
);
}
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
while
(
list
instanceof
Cons
)
{
if
(
item
.
eql
(((
Cons
)
list
).
car
))
return
list
;
list
=
((
Cons
)
list
).
cdr
;
}
if
(
list
!=
NIL
)
type_error
(
list
,
Symbol
.
LIST
);
return
NIL
;
}
};
while
(
list
instanceof
Cons
)
{
if
(
item
.
eql
(((
Cons
)
list
).
car
))
return
list
;
list
=
((
Cons
)
list
).
cdr
;
}
if
(
list
!=
NIL
)
type_error
(
list
,
Symbol
.
LIST
);
return
NIL
;
}
}
// ### adjoin-eql item list => new-list
private
static
final
Primitive
ADJOIN_EQL
=
new
Primitive
(
Symbol
.
ADJOIN_EQL
,
"item list"
)
private
static
final
Primitive
ADJOIN_EQL
=
new
adjoin_eql
();
private
static
class
adjoin_eql
extends
Primitive
{
adjoin_eql
()
{
super
(
Symbol
.
ADJOIN_EQL
,
"item list"
);
}
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
@Override
public
LispObject
execute
(
LispObject
item
,
LispObject
list
)
{
return
memql
(
item
,
list
)
?
list
:
new
Cons
(
item
,
list
);
}
};
return
memql
(
item
,
list
)
?
list
:
new
Cons
(
item
,
list
);
}
}
// ### special-variable-p
private
static
final
Primitive
SPECIAL_VARIABLE_P
=
new
Primitive
(
"special-variable-p"
,
PACKAGE_EXT
,
true
)
private
static
final
Primitive
SPECIAL_VARIABLE_P
=
new
special_variable_p
();
private
static
class
special_variable_p
extends
Primitive
{
special_variable_p
()
{
super
(
"special-variable-p"
,
PACKAGE_EXT
,
true
);
}
@Override
public
LispObject
execute
(
LispObject
arg
)
{
@Override
public
LispObject
execute
(
LispObject
arg
)
{
return
arg
.
isSpecialVariable
()
?
T
:
NIL
;
}
};
return
arg
.
isSpecialVariable
()
?
T
:
NIL
;
}
}
// ### source
private
static
final
Primitive
SOURCE
=
new
Primitive
(
"source"
,
PACKAGE_EXT
,
true
)
// ### source symbol
private
static
final
Primitive
SOURCE
=
new
source
();
private
static
class
source
extends
Primitive
{
source
()
{
super
(
"source"
,
PACKAGE_EXT
,
true
);
}
@Override
public
LispObject
execute
(
LispObject
arg
)
{
@Override
public
LispObject
execute
(
LispObject
arg
)
{
return
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
}
};
return
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
}
}
// ### source-file-position
private
static
final
Primitive
SOURCE_FILE_POSITION
=
new
Primitive
(
"source-file-position"
,
PACKAGE_EXT
,
true
)
// ### source-file-position symbol
private
static
final
Primitive
SOURCE_FILE_POSITION
=
new
source_file_position
();
private
static
class
source_file_position
extends
Primitive
{
source_file_position
()
{
super
(
"source-file-position"
,
PACKAGE_EXT
,
true
);
}
@Override
public
LispObject
execute
(
LispObject
arg
)
{
@Override
public
LispObject
execute
(
LispObject
arg
)
{
LispObject
obj
=
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
if
(
obj
instanceof
Cons
)
return
obj
.
cdr
();
return
NIL
;
}
};
LispObject
obj
=
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
if
(
obj
instanceof
Cons
)
return
obj
.
cdr
();
return
NIL
;
}
}
// ### source-pathname
public
static
final
Primitive
SOURCE_PATHNAME
=
new
Primitive
(
"source-pathname"
,
PACKAGE_EXT
,
true
)
public
static
final
Primitive
SOURCE_PATHNAME
=
new
source_pathname
();
private
static
class
source_pathname
extends
Primitive
{
source_pathname
()
{
super
(
"source-pathname"
,
PACKAGE_EXT
,
true
);
}
@Override
public
LispObject
execute
(
LispObject
arg
)
{
@Override
public
LispObject
execute
(
LispObject
arg
)
{
LispObject
obj
=
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
if
(
obj
instanceof
Cons
)
return
obj
.
car
();
return
obj
;
}
};
LispObject
obj
=
get
(
arg
,
Symbol
.
_SOURCE
,
NIL
);
if
(
obj
instanceof
Cons
)
return
obj
.
car
();
return
obj
;
}
}
// ### exit
private
static
final
Primitive
EXIT
=
new
Primitive
(
"exit"
,
PACKAGE_EXT
,
true
,
"&key status"
)
private
static
final
Primitive
EXIT
=
new
exit
();
private
static
class
exit
extends
Primitive
{
exit
()
{
super
(
"exit"
,
PACKAGE_EXT
,
true
,
"&key status"
);
}
@Override
public
LispObject
execute
()
{
@Override
public
LispObject
execute
()
{
exit
(
0
);
return
LispThread
.
currentThread
().
nothing
();
}
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
int
status
=
0
;
if
(
first
==
Keyword
.
STATUS
)
{
if
(
second
instanceof
Fixnum
)
status
=
((
Fixnum
)
second
).
value
;
}
exit
(
status
);
return
LispThread
.
currentThread
().
nothing
();
}
};
exit
(
0
);
return
LispThread
.
currentThread
().
nothing
();
}
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
int
status
=
0
;
if
(
first
==
Keyword
.
STATUS
)
{
if
(
second
instanceof
Fixnum
)
status
=
((
Fixnum
)
second
).
value
;
}
exit
(
status
);
return
LispThread
.
currentThread
().
nothing
();
}
}
// ### quit
private
static
final
Primitive
QUIT
=
new
Primitive
(
"quit"
,
PACKAGE_EXT
,
true
,
"&key status"
)
private
static
final
Primitive
QUIT
=
new
quit
();
private
static
class
quit
extends
Primitive
{
quit
()
{
super
(
"quit"
,
PACKAGE_EXT
,
true
,
"&key status"
);
}
@Override
public
LispObject
execute
()
{
@Override
public
LispObject
execute
()
{
exit
(
0
);
return
LispThread
.
currentThread
().
nothing
();
}
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
int
status
=
0
;
if
(
first
==
Keyword
.
STATUS
)
{
if
(
second
instanceof
Fixnum
)
status
=
((
Fixnum
)
second
).
value
;
}
exit
(
status
);
return
LispThread
.
currentThread
().
nothing
();
}
};
exit
(
0
);
return
LispThread
.
currentThread
().
nothing
();
}
@Override
public
LispObject
execute
(
LispObject
first
,
LispObject
second
)
{
int
status
=
0
;
if
(
first
==
Keyword
.
STATUS
)
{
if
(
second
instanceof
Fixnum
)
status
=
((
Fixnum
)
second
).
value
;
}
exit
(
status
);
return
LispThread
.
currentThread
().
nothing
();
}
}
// ### dump-java-stack
private
static
final
Primitive
DUMP_JAVA_STACK
=
new
Primitive
(
"dump-java-stack"
,
PACKAGE_EXT
,
true
)
private
static
final
Primitive
DUMP_JAVA_STACK
=
new
dump_java_stack
();
private
static
class
dump_java_stack
extends
Primitive
{
dump_java_stack
()
{
super
(
"dump-java-stack"
,
PACKAGE_EXT
,
true
);
}
@Override
public
LispObject
execute
()
{
@Override
public
LispObject
execute
()
{
Thread
.
dumpStack
();
return
LispThread
.
currentThread
().
nothing
();
}
};
Thread
.
dumpStack
();
return
LispThread
.
currentThread
().
nothing
();
}
}
// ### make-temp-file => namestring
private
static
final
Primitive
MAKE_TEMP_FILE
=
new
Primitive
(
"make-temp-file"
,
PACKAGE_EXT
,
true
,
""
)
// ### make-temp-file => pathname
private
static
final
Primitive
MAKE_TEMP_FILE
=
new
make_temp_file
();
private
static
class
make_temp_file
extends
Primitive
{
make_temp_file
()
{
super
(
"make-temp-file"
,
PACKAGE_EXT
,
true
,
""
);
}
@Override
public
LispObject
execute
()
{
@Override
public
LispObject
execute
()
{
try
{
File
file
=
File
.
createTempFile
(
"abcl"
,
null
,
null
);
if
(
file
!=
null
)
return
new
Pathname
(
file
.
getPath
());
}
catch
(
IOException
e
)
{
Debug
.
trace
(
e
);
}
return
NIL
;
}
};
try
{
File
file
=
File
.
createTempFile
(
"abcl"
,
null
,
null
);
if
(
file
!=
null
)
return
new
Pathname
(
file
.
getPath
());
}
catch
(
IOException
e
)
{
Debug
.
trace
(
e
);
}
return
NIL
;
}
}
// ### interrupt-lisp
private
static
final
Primitive
INTERRUPT_LISP
=
new
Primitive
(
"interrupt-lisp"
,
PACKAGE_EXT
,
true
,
""
)
private
static
final
Primitive
INTERRUPT_LISP
=
new
interrupt_lisp
();
private
static
class
interrupt_lisp
extends
Primitive
{
interrupt_lisp
()
{
super
(
"interrupt-lisp"
,
PACKAGE_EXT
,
true
,
""
);
}
@Override
public
LispObject
execute
()
{
@Override
public
LispObject
execute
()
{
setInterrupted
(
true
);
return
T
;
}
};
setInterrupted
(
true
);
return
T
;
}
}
// ### getenv
private
static
final
Primitive
GETENV
=
new
Primitive
(
"getenv"
,
PACKAGE_EXT
,
true
)
// ### getenv
variable => string
private
static
final
Primitive
GETENV
=
new
getenv
();
private
static
class
getenv
extends
Primitive
{
getenv
()
{
super
(
"getenv"
,
PACKAGE_EXT
,
true
,
"variable"
,
"Return the value of the environment VARIABLE if it exists, otherwise return NIL."
);
}
@Override
public
LispObject
execute
(
LispObject
arg
)
{
...
...
@@ -286,5 +318,5 @@ public final class Extensions
else
return
NIL
;
}
}
;
}
}
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment