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
Open sidebar
emacs
emacs
Commits
044512ed
Commit
044512ed
authored
Aug 04, 1992
by
Richard M. Stallman
Browse files
entered into RCS
parent
cefabdab
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
181 additions
and
363 deletions
+181
-363
src/bytecode.c
src/bytecode.c
+85
-182
src/callproc.c
src/callproc.c
+96
-181
No files found.
src/bytecode.c
View file @
044512ed
/* Execution of byte code produced by bytecomp.el.
Copyright (C) 1985, 1986, 1987, 1988
, 1992
Free Software Foundation, Inc.
Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version
2
, or (at your option)
the Free Software Foundation; either version
1
, or (at your option)
any later version.
GNU Emacs is distributed in the hope that it will be useful,
...
...
@@ -17,12 +17,14 @@ You should have received a copy of the GNU General Public License
along with GNU Emacs; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
hacked on by jwz
@lucid.com
17-jun-91
hacked on by jwz 17-jun-91
o added a compile-time switch to turn on simple sanity checking;
o put back the obsolete byte-codes for error-detection;
o put back fset, symbol-function, and read-char because I don't
see any reason for them to have been removed;
o added a new instruction, unbind_all, which I will use for
tail-recursion elimination;
o made temp_output_buffer_show be called with the right number
o made temp_output_buffer_show
()
be called with the right number
of args;
o made the new bytecodes be called with args in the right order;
o added metering support.
...
...
@@ -32,49 +34,48 @@ by Hallvard:
o all conditionals now only do QUIT if they jump.
*/
#include "config.h"
#include "lisp.h"
#include "buffer.h"
#include "syntax.h"
/*
* define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
* debugging the byte compiler...)
*
* define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
/* Define this to enable some minor sanity checking
(useful for debugging the byte compiler...)
*/
#define BYTE_CODE_SAFE
/* Define this to enable generation of a histogram of byte-op usage.
*/
/* #define BYTE_CODE_SAFE */
/* #define BYTE_CODE_METER */
#define BYTE_CODE_METER
#ifdef BYTE_CODE_METER
Lisp_Object
Vbyte_code_meter
,
Qbyte_code_meter
;
Lisp_Object
Vbyte_code_meter
;
int
byte_metering_on
;
#define METER_2(code1,
code2) \
#
define METER_2(code1,code2) \
XFASTINT (XVECTOR (XVECTOR (Vbyte_code_meter)->contents[(code1)]) \
->contents[(code2)])
#define METER_1(code) METER_2 (0, (code))
#define METER_CODE(last_code, this_code) \
{ \
if (byte_metering_on) \
{ \
if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
METER_1 (this_code)++; \
if (last_code \
&& METER_2 (last_code, this_code) != ((1<<VALBITS)-1)) \
METER_2 (last_code, this_code)++; \
} \
}
# define METER_1(code) METER_2 (0,(code))
#else
/* no BYTE_CODE_METER */
# define METER_CODE(last_code, this_code) { \
if (byte_metering_on) { \
if (METER_1 (this_code) != ((1<<VALBITS)-1)) \
METER_1 (this_code) ++; \
if (last_code && \
METER_2 (last_code,this_code) != ((1<<VALBITS)-1)) \
METER_2 (last_code,this_code) ++; \
} \
}
#
define ME
TE
R
_CODE
(last_code, this_code)
#
else
/* ! BY
TE_CODE
_METER */
#endif
/* no BYTE_CODE_METER */
# define meter_code(last_code, this_code)
#endif
Lisp_Object
Qbytecode
;
...
...
@@ -146,7 +147,7 @@ Lisp_Object Qbytecode;
#define Bbobp 0157
#define Bcurrent_buffer 0160
#define Bset_buffer 0161
#define Bread_char 0162
/* No longer generated as of v19 */
#define Bread_char 0162
#define Bset_mark 0163
/* this loser is no longer generated as of v18 */
#define Binteractive_p 0164
/* Needed since interactive-p takes unevalled args */
...
...
@@ -160,7 +161,6 @@ Lisp_Object Qbytecode;
#define Bdelete_region 0174
#define Bnarrow_to_region 0175
#define Bwiden 0176
#define Bend_of_line 0177
#define Bconstant2 0201
#define Bgoto 0202
...
...
@@ -184,12 +184,6 @@ Lisp_Object Qbytecode;
#define Bunbind_all 0222
#define Bset_marker 0223
#define Bmatch_beginning 0224
#define Bmatch_end 0225
#define Bupcase 0226
#define Bdowncase 0227
#define Bstringeqlsign 0230
#define Bstringlss 0231
#define Bequal 0232
...
...
@@ -208,16 +202,6 @@ Lisp_Object Qbytecode;
#define Bnumberp 0247
#define Bintegerp 0250
#define BRgoto 0252
#define BRgotoifnil 0253
#define BRgotoifnonnil 0254
#define BRgotoifnilelsepop 0255
#define BRgotoifnonnilelsepop 0256
#define BlistN 0257
#define BconcatN 0260
#define BinsertN 0261
#define Bconstant 0300
#define CONSTANTLIM 0100
...
...
@@ -301,10 +285,11 @@ If the third argument is incorrect, Emacs may crash.")
{
#ifdef BYTE_CODE_SAFE
if
(
stackp
>
stacke
)
error
(
"Byte code stack overflow (byte compiler bug), pc %d, depth %d"
,
error
(
"Stack overflow in byte code (byte compiler bug), pc = %d, depth = %d"
,
pc
-
XSTRING
(
string_saved
)
->
data
,
stacke
-
stackp
);
if
(
stackp
<
stack
)
error
(
"
Byte code s
tack underflow (byte compiler bug), pc %d"
,
error
(
"
S
tack underflow
in byte code
(byte compiler bug), pc
=
%d"
,
pc
-
XSTRING
(
string_saved
)
->
data
);
#endif
...
...
@@ -405,19 +390,7 @@ If the third argument is incorrect, Emacs may crash.")
case
Bcall
+
4
:
case
Bcall
+
5
:
op
-=
Bcall
;
docall:
DISCARD
(
op
);
#ifdef BYTE_CODE_METER
if
(
byte_metering_on
&&
XTYPE
(
TOP
)
==
Lisp_Symbol
)
{
v1
=
TOP
;
v2
=
Fget
(
v1
,
Qbyte_code_meter
);
if
(
XTYPE
(
v2
)
==
Lisp_Int
)
{
XSETINT
(
v2
,
XINT
(
v2
)
+
1
);
Fput
(
v1
,
Qbyte_code_meter
,
v2
);
}
}
#endif
DISCARD
(
op
);
TOP
=
Ffuncall
(
op
+
1
,
&
TOP
);
break
;
...
...
@@ -438,7 +411,8 @@ If the third argument is incorrect, Emacs may crash.")
case
Bunbind_all
:
/* To unbind back to the beginning of this frame. Not used yet,
but will be needed for tail-recursion elimination. */
but wil be needed for tail-recursion elimination.
*/
unbind_to
(
count
,
Qnil
);
break
;
...
...
@@ -450,7 +424,7 @@ If the third argument is incorrect, Emacs may crash.")
case
Bgotoifnil
:
op
=
FETCH2
;
if
(
N
ILP
(
POP
))
if
(
N
ULL
(
POP
))
{
QUIT
;
pc
=
XSTRING
(
string_saved
)
->
data
+
op
;
...
...
@@ -459,7 +433,7 @@ If the third argument is incorrect, Emacs may crash.")
case
Bgotoifnonnil
:
op
=
FETCH2
;
if
(
!
N
ILP
(
POP
))
if
(
!
N
ULL
(
POP
))
{
QUIT
;
pc
=
XSTRING
(
string_saved
)
->
data
+
op
;
...
...
@@ -468,65 +442,22 @@ If the third argument is incorrect, Emacs may crash.")
case
Bgotoifnilelsepop
:
op
=
FETCH2
;
if
(
N
ILP
(
TOP
))
if
(
N
ULL
(
TOP
))
{
QUIT
;
pc
=
XSTRING
(
string_saved
)
->
data
+
op
;
}
else
DISCARD
(
1
);
else
DISCARD
(
1
);
break
;
case
Bgotoifnonnilelsepop
:
op
=
FETCH2
;
if
(
!
N
ILP
(
TOP
))
if
(
!
N
ULL
(
TOP
))
{
QUIT
;
pc
=
XSTRING
(
string_saved
)
->
data
+
op
;
}
else
DISCARD
(
1
);
break
;
case
BRgoto
:
QUIT
;
pc
+=
*
pc
-
127
;
break
;
case
BRgotoifnil
:
if
(
NILP
(
POP
))
{
QUIT
;
pc
+=
*
pc
-
128
;
}
pc
++
;
break
;
case
BRgotoifnonnil
:
if
(
!
NILP
(
POP
))
{
QUIT
;
pc
+=
*
pc
-
128
;
}
pc
++
;
break
;
case
BRgotoifnilelsepop
:
op
=
*
pc
++
;
if
(
NILP
(
TOP
))
{
QUIT
;
pc
+=
op
-
128
;
}
else
DISCARD
(
1
);
break
;
case
BRgotoifnonnilelsepop
:
op
=
*
pc
++
;
if
(
!
NILP
(
TOP
))
{
QUIT
;
pc
+=
op
-
128
;
}
else
DISCARD
(
1
);
else
DISCARD
(
1
);
break
;
case
Breturn
:
...
...
@@ -534,7 +465,7 @@ If the third argument is incorrect, Emacs may crash.")
goto
exit
;
case
Bdiscard
:
DISCARD
(
1
);
DISCARD
(
1
);
break
;
case
Bdup
:
...
...
@@ -598,7 +529,7 @@ If the third argument is incorrect, Emacs may crash.")
{
if
(
CONSP
(
v1
))
v1
=
XCONS
(
v1
)
->
cdr
;
else
if
(
!
N
ILP
(
v1
))
else
if
(
!
N
ULL
(
v1
))
{
immediate_quit
=
0
;
v1
=
wrong_type_argument
(
Qlistp
,
v1
);
...
...
@@ -622,7 +553,7 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Blistp
:
TOP
=
CONSP
(
TOP
)
||
N
ILP
(
TOP
)
?
Qt
:
Qnil
;
TOP
=
CONSP
(
TOP
)
||
N
ULL
(
TOP
)
?
Qt
:
Qnil
;
break
;
case
Beq
:
...
...
@@ -636,21 +567,21 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bnot
:
TOP
=
N
ILP
(
TOP
)
?
Qt
:
Qnil
;
TOP
=
N
ULL
(
TOP
)
?
Qt
:
Qnil
;
break
;
case
Bcar
:
v1
=
TOP
;
docar:
if
(
CONSP
(
v1
))
TOP
=
XCONS
(
v1
)
->
car
;
else
if
(
N
ILP
(
v1
))
TOP
=
Qnil
;
else
if
(
N
ULL
(
v1
))
TOP
=
Qnil
;
else
Fcar
(
wrong_type_argument
(
Qlistp
,
v1
));
break
;
case
Bcdr
:
v1
=
TOP
;
if
(
CONSP
(
v1
))
TOP
=
XCONS
(
v1
)
->
cdr
;
else
if
(
N
ILP
(
v1
))
TOP
=
Qnil
;
else
if
(
N
ULL
(
v1
))
TOP
=
Qnil
;
else
Fcdr
(
wrong_type_argument
(
Qlistp
,
v1
));
break
;
...
...
@@ -669,21 +600,15 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Blist3
:
DISCARD
(
2
);
DISCARD
(
2
);
TOP
=
Flist
(
3
,
&
TOP
);
break
;
case
Blist4
:
DISCARD
(
3
);
DISCARD
(
3
);
TOP
=
Flist
(
4
,
&
TOP
);
break
;
case
BlistN
:
op
=
FETCH
;
DISCARD
(
op
-
1
);
TOP
=
Flist
(
op
,
&
TOP
);
break
;
case
Blength
:
TOP
=
Flength
(
TOP
);
break
;
...
...
@@ -727,26 +652,20 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bconcat2
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fconcat
(
2
,
&
TOP
);
break
;
case
Bconcat3
:
DISCARD
(
2
);
DISCARD
(
2
);
TOP
=
Fconcat
(
3
,
&
TOP
);
break
;
case
Bconcat4
:
DISCARD
(
3
);
DISCARD
(
3
);
TOP
=
Fconcat
(
4
,
&
TOP
);
break
;
case
BconcatN
:
op
=
FETCH
;
DISCARD
(
op
-
1
);
TOP
=
Fconcat
(
op
,
&
TOP
);
break
;
case
Bsub1
:
v1
=
TOP
;
if
(
XTYPE
(
v1
)
==
Lisp_Int
)
...
...
@@ -797,7 +716,7 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bdiff
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fminus
(
2
,
&
TOP
);
break
;
...
...
@@ -813,32 +732,33 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bplus
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fplus
(
2
,
&
TOP
);
break
;
case
Bmax
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fmax
(
2
,
&
TOP
);
break
;
case
Bmin
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fmin
(
2
,
&
TOP
);
break
;
case
Bmult
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Ftimes
(
2
,
&
TOP
);
break
;
case
Bquo
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fquo
(
2
,
&
TOP
);
break
;
case
Brem
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Frem
(
TOP
,
v1
);
break
;
...
...
@@ -855,12 +775,6 @@ If the third argument is incorrect, Emacs may crash.")
TOP
=
Finsert
(
1
,
&
TOP
);
break
;
case
BinsertN
:
op
=
FETCH
;
DISCARD
(
op
-
1
);
TOP
=
Finsert
(
op
,
&
TOP
);
break
;
case
Bpoint_max
:
XFASTINT
(
v1
)
=
ZV
;
PUSH
(
v1
);
...
...
@@ -928,24 +842,29 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bforward_char
:
/* This was wrong! --jwz */
TOP
=
Fforward_char
(
TOP
);
break
;
case
Bforward_word
:
/* This was wrong! --jwz */
TOP
=
Fforward_word
(
TOP
);
break
;
case
Bskip_chars_forward
:
/* This was wrong! --jwz */
v1
=
POP
;
TOP
=
Fskip_chars_forward
(
TOP
,
v1
);
break
;
case
Bskip_chars_backward
:
/* This was wrong! --jwz */
v1
=
POP
;
TOP
=
Fskip_chars_backward
(
TOP
,
v1
);
break
;
case
Bforward_line
:
/* This was wrong! --jwz */
TOP
=
Fforward_line
(
TOP
);
break
;
...
...
@@ -961,11 +880,13 @@ If the third argument is incorrect, Emacs may crash.")
case
Bdelete_region
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fdelete_region
(
TOP
,
v1
);
break
;
case
Bnarrow_to_region
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fnarrow_to_region
(
TOP
,
v1
);
break
;
...
...
@@ -973,49 +894,27 @@ If the third argument is incorrect, Emacs may crash.")
PUSH
(
Fwiden
());
break
;
case
Bend_of_line
:
TOP
=
Fend_of_line
(
TOP
);
break
;
case
Bset_marker
:
v1
=
POP
;
v2
=
POP
;
TOP
=
Fset_marker
(
TOP
,
v2
,
v1
);
break
;
case
Bmatch_beginning
:
TOP
=
Fmatch_beginning
(
TOP
);
break
;
case
Bmatch_end
:
TOP
=
Fmatch_end
(
TOP
);
break
;
case
Bupcase
:
TOP
=
Fupcase
(
TOP
);
break
;
case
Bdowncase
:
TOP
=
Fdowncase
(
TOP
);
break
;
case
Bstringeqlsign
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fstring_equal
(
TOP
,
v1
);
break
;
case
Bstringlss
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fstring_lessp
(
TOP
,
v1
);
break
;
case
Bequal
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fequal
(
TOP
,
v1
);
break
;
case
Bnthcdr
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fnthcdr
(
TOP
,
v1
);
break
;
...
...
@@ -1033,11 +932,13 @@ If the third argument is incorrect, Emacs may crash.")
case
Bmember
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fmember
(
TOP
,
v1
);
break
;
case
Bassq
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fassq
(
TOP
,
v1
);
break
;
...
...
@@ -1047,11 +948,13 @@ If the third argument is incorrect, Emacs may crash.")
case
Bsetcar
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fsetcar
(
TOP
,
v1
);
break
;
case
Bsetcdr
:
v1
=
POP
;
/* This had args in the wrong order. -- jwz */
TOP
=
Fsetcdr
(
TOP
,
v1
);
break
;
...
...
@@ -1072,12 +975,13 @@ If the third argument is incorrect, Emacs may crash.")
break
;
case
Bnconc
:
DISCARD
(
1
);
DISCARD
(
1
);
TOP
=
Fnconc
(
2
,
&
TOP
);
break
;
case
Bnumberp
:
TOP
=
(
NUMBERP
(
TOP
)
?
Qt
:
Qnil
);
TOP
=
(
XTYPE
(
TOP
)
==
Lisp_Int
||
XTYPE
(
TOP
)
==
Lisp_Float
?
Qt
:
Qnil
);
break
;
case
Bintegerp
:
...
...
@@ -1092,7 +996,7 @@ If the third argument is incorrect, Emacs may crash.")
error
(
"scan-buffer is an obsolete bytecode"
);
break
;
case
Bmark
:
error
(
"mark is an obsolete bytecode"
);
error
(
"mark is an obsolete bytecode"
);
break
;
#endif
...
...
@@ -1131,18 +1035,17 @@ syms_of_bytecode ()
#ifdef BYTE_CODE_METER
DEFVAR_LISP
(
"byte-code-meter"
,
&
Vbyte_code_meter
,
"
A
vector of vectors which holds a histogram of byte-code usage."
);
"
a
vector of vectors which holds a histogram of byte-code usage."
);
DEFVAR_BOOL
(
"byte-metering-on"
,
&
byte_metering_on
,
""
);
byte_metering_on
=
0
;
Vbyte_code_meter
=
Fmake_vector
(
make_number
(
256
),
make_number
(
0
));
Qbyte_code_meter
=
intern
(
"byte-code-meter"
);
staticpro
(
&
Qbyte_code_meter
);
Vbyte_code_meter
=
Fmake_vector
(
make_number
(
256
),
make_number
(
0
));
{
int
i
=
256
;
while
(
i
--
)
XVECTOR
(
Vbyte_code_meter
)
->
contents
[
i
]
=
Fmake_vector
(
make_number
(
256
),
make_number
(
0
));
XVECTOR
(
Vbyte_code_meter
)
->
contents
[
i
]
=
Fmake_vector
(
make_number
(
256
),
make_number
(
0
));
}
#endif
}
src/callproc.c
View file @
044512ed
/* Synchronous subprocess invocation for GNU Emacs.
Copyright (C) 1985, 1986, 1987, 1988
, 1992
Free Software Foundation, Inc.
Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
This file is part of GNU Emacs.
...
...
@@ -19,7 +19,6 @@ the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include <signal.h>
#include <errno.h>
#include "config.h"
...
...
@@ -58,11 +57,16 @@ extern char **environ;
#define max(a, b) ((a) > (b) ? (a) : (b))
Lisp_Object
Vexec_path
,
Vexec_directory
,
Vdata_directory
;
Lisp_Object
Vexec_path
,
Vexec_directory
;
Lisp_Object
Vshell_file_name
;
#ifndef MAINTAIN_ENVIRONMENT
/* List of strings to append to front of environment of
all subprocesses when they are started. */
Lisp_Object
Vprocess_environment
;
#endif
/* True iff we are about to fork off a synchronous process or if we
are waiting for it. */
...
...
@@ -99,13 +103,13 @@ Fourth arg DISPLAY non-nil means redisplay buffer as output is inserted.\n\
Remaining arguments are strings passed as command arguments to PROGRAM.
\n
\
If BUFFER is nil or 0, returns immediately with value nil.
\n
\
Otherwise waits for PROGRAM to terminate
\n
\
and returns a numeric exit status or a signal
description
string.
\n
\
and returns a numeric exit status or a signal
name as a
string.
\n
\
If you quit, the process is killed with SIGKILL."
)
(
nargs
,
args
)
int
nargs
;
register
Lisp_Object
*
args
;
{
Lisp_Object
display
,
infile
,
buffer
,
path
,
current_dir
;
Lisp_Object
display
,
buffer
,
path
;
int
fd
[
2
];
int
filefd
;