| git.druid.rocks | index | druid520 | nscc | src/ | jlex0.pl |
src/jlex0.pl
#!/usr/bin/env perl
# jlex0 -- the nsc lexer, first stage of the nscc pipeline. owns: char
# classes, the keyword set, numeric literal parsing, string/char
# literals (with their escape decoding -- the value field carries the
# source text exactly, escapes still escaped, so no information is lost
# before jparse1), comments (/* */ only -- no //, no nesting), and
# line/column tracking. output format .toks.j0: one token per line,
# "TOK TEXT L:C", where TEXT is the raw lexeme -- escaped for
# STRLIT/CHARLIT only (a string literal can contain spaces, which
# would otherwise break the one-token-per-line format) -- and a final
# "EOF - L:C" line closes every file. keywords and type names become
# their own uppercase token types (RETURN, I32, ...) so jparse1 never
# re-splits ident text.
#
# the keyword list below is the single source of truth for nsc's
# reserved words (docs/nsc.btft enumerates it; this is the one place
# it actually lives): the type words, the statement words, the five
# c89 words nsc reserves for a future version (struct, typedef,
# unsigned, enum, const -- lexed as keywords so they can never be
# identifiers, and rejected by jparse1 with a clear message), include
# (consumed entirely by this stage's own preproc step -- see below --
# so jparse1 only ever sees a bare INCLUDE token if a malformed
# include line failed to match and fell through to real lexing, which
# it also rejects with a clear message), and sizeof. an identifier
# starting with __ (double underscore) is reserved for the
# implementation and is an error. there is no line splicing (a
# backslash never joins lines) and no trigraph processing.
#
# this stage's own mini pipeline: in -- preproc -- proc -- out, where
# preproc is line-ending normalization (strip CR, guarantee a trailing
# newline) PLUS include expansion (textual, recursive, cycle-checked --
# see expand_includes) and proc is the lexing proper. include expansion
# has to happen here, in preproc, before real lexing: it's the only
# stage that ever sees more than one file, and doing it as pure text
# substitution (rather than teaching the lexer to splice token streams
# from multiple files) keeps every later stage exactly as unaware of
# multi-file compilation as it already was.
use v5.16;
use strict;
use warnings FATAL => 'all';
use FindBin;
use lib "$FindBin::Bin";
use File::Basename qw(dirname);
use Cwd qw(abs_path);
use jcplib::util qw(stage_err);
my $SRC = do { local $/; <STDIN>; };
# the complete nsc keyword set (the single source of truth, enumerated
# in docs/nsc.btft): the type words, the statement words, the decl
# words (const, typedef, struct, enum), and sizeof. unsigned stays a
# keyword so it can never be an identifier, but it stands for nothing:
# unsigned types are spelled u8/u16/u32/u64 (jparse1 rejects it with a
# pointer to that). an identifier starting with __ (double underscore)
# is reserved for the implementation and is an error.
my %KEYWORDS = map { $_ => 1 } qw(global if else while return break continue switch case default struct typedef unsigned enum const sizeof include);
my %TYPES = map { $_ => 1 } qw(i8 i16 i32 i64 u8 u16 u32 u64 ptr void);
# punctuation, longest first (so <<= wins over << and <); the token
# type is a mnemonic (ASSIGN, PLUSEQ, ...) and the lexeme is kept as-is.
my @PUNCT = ('<<=', '>>=', '&&', '||', '==', '!=', '<=', '>=', '+=', '-=', '*=', '/=', '%=', '&=', '|=', '^=', '++', '--', '->', '<<', '>>', '+', '-', '*', '/', '%', '&', '|', '^', '~', '!', '<', '>', '=', '?', ':', ';', ',', '(', ')', '{', '}', '[', ']', '.');
my %PUNCT_TEXT = (
'+' => 'PLUS', '-' => 'MINUS', '*' => 'STAR', '/' => 'SLASH', '%' => 'PERCENT',
'&' => 'AMP', '|' => 'PIPE', '^' => 'CARET', '~' => 'TILDE', '!' => 'BANG',
'<' => 'LT', '>' => 'GT', '=' => 'ASSIGN', '?' => 'QUES', ':' => 'COLON',
';' => 'SEMI', ',' => 'COMMA', '(' => 'LPAREN', ')' => 'RPAREN',
'{' => 'LBRACE', '}' => 'RBRACE', '[' => 'LBRACKET', ']' => 'RBRACKET',
'<<' => 'LSHIFT', '>>' => 'RSHIFT', '<<=' => 'LSHIFTEQ', '>>=' => 'RSHIFTEQ',
'==' => 'EQ', '!=' => 'NE', '<=' => 'LE', '>=' => 'GE',
'+=' => 'PLUSEQ', '-=' => 'MINUSEQ', '*=' => 'STAREQ', '/=' => 'SLASHEQ',
'%=' => 'PERCENTEQ', '&=' => 'AMPEQ', '|=' => 'PIPEEQ', '^=' => 'CARETEQ',
'++' => 'INC', '--' => 'DEC', '&&' => 'ANDAND', '||' => 'OROR', '->' => 'ARROW', '.' => 'DOT',
);
my %KEYWORD_TOK = map { $_ => uc($_) } keys %KEYWORDS;
my %TYPE_TOK = map { $_ => uc($_) } keys %TYPES;
sub die_lncol {
my ($line, $col, $msg) = @_;
my $file = $ENV{NSCC_FILE} || 'input';
stage_err("jlex0: $file:$line:$col: $msg");
}
# escape the raw lexeme of a string/char literal so the token line can
# never contain a space (jparse1 unescapes it back).
sub esc_lexeme {
my ($s) = @_;
$s =~ s/([\\ ]|[^\x20-\x7E])/sprintf("\\x%02X", ord($1))/ge;
return $s;
}
sub lex {
my ($src) = @_;
my @toks;
my $line = 1;
my $col = 1;
my $len = length $src;
my $i = 0;
# consume one character, keeping line/col straight (a newline
# resets the column and bumps the line).
my $next = sub {
my $c = substr($src, $i, 1);
$i++;
if($c eq "\n") { $line++; $col = 1; }
else { $col++; }
return $c;
};
while($i < $len) {
my $c = substr($src, $i, 1);
# whitespace (outside literals): skipped, counted.
if($c eq ' ' || $c eq "\t" || $c eq "\n" || $c eq "\r" || $c eq "\f" || $c eq "\x0B") {
$next->();
next;
}
# comments: /* */ only (no //, per nsc; no nesting either --
# the first */ closes); unclosed is an error, not a silent EOF.
if($c eq '/' && substr($src, $i + 1, 1) eq '*') {
my ($sl, $sc) = ($line, $col);
$next->(); $next->();
my $closed = 0;
while($i < $len) {
if(substr($src, $i, 1) eq '*' && substr($src, $i + 1, 1) eq '/') { $next->(); $next->(); $closed = 1; last; }
$next->();
}
die_lncol($sl, $sc, 'unterminated comment') unless $closed;
next;
}
# identifiers and keywords; anything beginning with __ is
# reserved for the implementation and is an error.
if($c =~ /[A-Za-z_]/) {
my ($tl, $tc) = ($line, $col);
my $text = '';
while($i < $len && substr($src, $i, 1) =~ /[A-Za-z0-9_]/) { $text .= $next->(); }
die_lncol($tl, $tc, "identifier '$text' is reserved (double underscore)") if $text =~ /^__/;
my $t = exists $TYPE_TOK{$text} ? $TYPE_TOK{$text}
: exists $KEYWORD_TOK{$text} ? $KEYWORD_TOK{$text}
: 'IDENT';
push @toks, {t => $t, v => $text, l => $tl, c => $tc};
next;
}
# numbers: decimal or 0x-hex, no suffixes, no floats (nsc
# has none); a digit run followed immediately by an ident
# char is an error, not two tokens -- strictness wins.
if($c =~ /[0-9]/) {
my ($tl, $tc) = ($line, $col);
my $text = '';
if($c eq '0' && substr($src, $i + 1, 1) eq 'x') {
$text .= $next->(); $text .= $next->();
my $dig = 0;
while($i < $len && substr($src, $i, 1) =~ /[0-9A-Fa-f]/) { $text .= $next->(); $dig++; }
die_lncol($tl, $tc, "hex literal with no digits: $text") unless $dig;
}
else {
while($i < $len && substr($src, $i, 1) =~ /[0-9]/) { $text .= $next->(); }
}
die_lncol($tl, $tc, "invalid number: $text" . substr($src, $i, 1)) if $i < $len && substr($src, $i, 1) =~ /[A-Za-z_]/;
push @toks, {t => 'INTLIT', v => $text, l => $tl, c => $tc};
next;
}
# string literal: escapes stay raw in the lexeme (jparse1
# decodes them); an unescaped newline is an error.
if($c eq '"') {
my ($tl, $tc) = ($line, $col);
my $text = $next->();
while($i < $len && substr($src, $i, 1) ne '"') {
my $ch = $next->();
if($ch eq '\\') {
die_lncol($line, $col, 'unterminated string literal') unless $i < $len;
$text .= '\\' . $next->();
next;
}
die_lncol($tl, $tc, 'unterminated string literal (newline in string)') if $ch eq "\n";
$text .= $ch;
}
die_lncol($tl, $tc, 'unterminated string literal') unless $i < $len;
$text .= $next->();
push @toks, {t => 'STRLIT', v => esc_lexeme($text), l => $tl, c => $tc};
next;
}
# char literal: exactly one (possibly escaped) char; the \xNN
# escape counts as one char too (its two hex digits are part
# of the escape, not extra chars).
if($c eq "'") {
my ($tl, $tc) = ($line, $col);
my $text = $next->();
my $n = 0;
while($i < $len && substr($src, $i, 1) ne "'") {
my $ch = $next->();
$n++;
if($ch eq '\\') {
die_lncol($line, $col, 'unterminated char literal') unless $i < $len;
$text .= '\\' . $next->();
if(substr($text, -2) eq '\\x' && substr($src, $i, 2) =~ /^[0-9A-Fa-f]{2}$/) {
$text .= $next->() . $next->();
}
next;
}
die_lncol($tl, $tc, 'unterminated char literal (newline in char)') if $ch eq "\n";
$text .= $ch;
}
die_lncol($tl, $tc, 'unterminated char literal') unless $i < $len;
die_lncol($tl, $tc, "char literal must hold exactly one char, got $n") unless $n == 1;
$text .= $next->();
push @toks, {t => 'CHARLIT', v => esc_lexeme($text), l => $tl, c => $tc};
next;
}
# punctuation, longest match first.
my $matched = 0;
for my $p (@PUNCT) {
if(substr($src, $i, length $p) eq $p) {
my ($tl, $tc) = ($line, $col);
$next->() for 1 .. length $p;
push @toks, {t => $PUNCT_TEXT{$p}, v => $p, l => $tl, c => $tc};
$matched = 1;
last;
}
}
die_lncol($line, $col, sprintf('unexpected char: %s (0x%02X)', $c, ord $c)) unless $matched;
}
push @toks, {t => 'EOF', v => '-', l => $line, c => $col};
return \@toks;
}
# textual, recursive include expansion: a line that is (ignoring
# leading/trailing whitespace) exactly `include "path";` is replaced
# by the fully-expanded content of path, resolved relative to the
# file doing the including (c's own #include "..." rule, not cwd --
# a header can include a sibling header by its own bare name
# regardless of where the compiler was invoked from). the match is
# whole-line and requires the trailing semicolon deliberately: a
# looser match risks silently eating a real `include` identifier
# reference the moment this word is ever used for anything else, and
# requiring the exact directive shape means a typo (missing
# semicolon, unmatched quote) falls through to real lexing instead,
# where it surfaces as a real, clear parse error (see jparse1's
# INCLUDE rejection) rather than a silently-wrong expansion.
#
# known real limitation, not fixed here: error line numbers reported
# by every later stage are positions in the FULLY EXPANDED text, not
# the original line in whatever .nsh the error is actually in -- same
# rough edge c's own preprocessor had before #line markers existed.
# fixing this needs line/file remapping threaded through every stage
# that can ever report an error, not just this one; out of scope for
# a first cut of the feature.
sub expand_includes {
my ($text, $dir, $seen) = @_;
my $out = '';
for my $line (split /\n/, $text, -1) {
if ($line =~ /^\s*include\s+"([^"]+)"\s*;\s*$/) {
my $rel = $1;
my $path = "$dir/$rel";
stage_err("jlex0: include \"$rel\": no such file.") unless -f $path;
my $canon = abs_path($path) // $path;
stage_err("jlex0: include \"$rel\": circular include.") if $seen->{$canon};
open(my $fh, '<', $path) or stage_err("jlex0: include \"$rel\": $!.");
my $inc_text = do { local $/; <$fh>; };
close $fh;
local $seen->{$canon} = 1;
$out .= expand_includes($inc_text, dirname($path), $seen);
}
else {
$out .= "$line\n";
}
}
return $out;
}
# normalize line endings, guarantee a final newline so the EOF token's
# position is always well defined, and expand include directives.
sub preproc {
my ($text) = @_;
$text =~ s/\r\n/\n/g;
$text =~ s/\r/\n/g;
$text .= "\n" unless $text =~ /\n\z/;
my $top_dir = dirname($ENV{NSCC_FILE} // '.');
$text = expand_includes($text, $top_dir, {});
return $text;
}
sub proc {
my ($src) = @_;
my $toks = lex($src);
my $out = '';
for my $t (@$toks) { $out .= "$t->{t} $t->{v} $t->{l}:$t->{c}\n"; }
return $out;
}
print proc(preproc($SRC));