diff options
| -rw-r--r-- | src/ChangeLog | 10 | ||||
| -rw-r--r-- | src/boot/includer.boot | 6 | ||||
| -rw-r--r-- | src/boot/parser.boot | 58 | ||||
| -rw-r--r-- | src/boot/pile.boot | 22 | ||||
| -rw-r--r-- | src/boot/scanner.boot | 24 | ||||
| -rw-r--r-- | src/boot/strap/includer.clisp | 4 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 65 | ||||
| -rw-r--r-- | src/boot/strap/pile.clisp | 25 | ||||
| -rw-r--r-- | src/boot/strap/scanner.clisp | 23 | ||||
| -rw-r--r-- | src/boot/strap/tokens.clisp | 16 | ||||
| -rw-r--r-- | src/boot/tokens.boot | 16 | ||||
| -rw-r--r-- | src/boot/utility.boot | 2 | ||||
| -rw-r--r-- | src/interp/sys-utility.boot | 6 |
13 files changed, 135 insertions, 142 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 3f7b04b3..76d98aa1 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,5 +1,15 @@ 2012-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu> + * boot/tokens.boot (%Token): New datatype. + (makeToken): New. + * boot/includer.boot: Use %token accessors. + * boot/parser.boot: Likewise. + * boot/pile.boot: Likewise. + * boot/scanner.boot: Likewise. + * boot/utility.boot: Export subString. + +2012-05-22 Gabriel Dos Reis <gdr@cs.tamu.edu> + * interp/lexing.boot (%Token): Now an actual type defined as a record structure. (copyToken): Adjust. diff --git a/src/boot/includer.boot b/src/boot/includer.boot index 0d85ab14..d36932d5 100644 --- a/src/boot/includer.boot +++ b/src/boot/includer.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2011, Gabriel Dos Reis. +-- Copyright (C) 2007-2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -88,7 +88,7 @@ shoeSpaces n == --% diagnosticLocation tok == - pos := shoeTokPosn tok + pos := tokenPosition tok strconc('"line ", toString lineNo pos, '", column ", toString lineCharacter pos) @@ -99,7 +99,7 @@ SoftShoeError(posn,key)== shoeConsole key bpSpecificErrorAtToken(tok, key) == - a := shoeTokPosn tok + a := tokenPosition tok SoftShoeError(a,key) bpSpecificErrorHere(key) == diff --git a/src/boot/parser.boot b/src/boot/parser.boot index e698c359..414f21ca 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -48,17 +48,17 @@ module parser bpFirstToken()== $stok:= - $inputStream = nil => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + $inputStream = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok) first $inputStream - $ttok := shoeTokPart $stok + $ttok := tokenValue $stok true bpFirstTok()== $stok:= - $inputStream = nil => shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + $inputStream = nil => mk%Token("ERROR","NOMORE",tokenPosition $stok) first $inputStream - $ttok:=shoeTokPart $stok - $bpParenCount>0 and $stok is ["KEY",:.] => + $ttok := tokenValue $stok + $bpParenCount > 0 and tokenClass $stok = "KEY" => $ttok is "SETTAB" => $bpCount:=$bpCount+1 bpNext() @@ -244,13 +244,13 @@ bpBacksetElse()== bpEqKey "ELSE" bpEqPeek s == - $stok is ["KEY",:.] and symbolEq?(s,$ttok) + tokenClass $stok = "KEY" and symbolEq?(s,$ttok) bpEqKey s == - $stok is ["KEY",:.] and symbolEq?(s,$ttok) and bpNext() + tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNext() bpEqKeyNextTok s == - $stok is ["KEY",:.] and symbolEq?(s,$ttok) and bpNextToken() + tokenClass $stok = "KEY" and symbolEq?(s,$ttok) and bpNextToken() bpPileTrap() == bpMissing "BACKTAB" bpBrackTrap(x) == bpMissingMate("]",x) @@ -272,9 +272,9 @@ bpTrap()== bpRecoverTrap()== bpFirstToken() - pos1 := shoeTokPosn $stok + pos1 := tokenPosition $stok bpMoveTo 0 - pos2 := shoeTokPosn $stok + pos2 := tokenPosition $stok bpIgnoredFromTo(pos1, pos2) bpPush [['"pile syntax error"]] @@ -352,7 +352,7 @@ bpMoveTo n== bpQualifiedName() == bpEqPeek "COLON-COLON" => bpNext() - $stok is ["ID",:.] and bpPushId() and bpNext() + tokenClass $stok = "ID" and bpPushId() and bpNext() and bpPush bfColonColon(bpPop2(), bpPop1()) false @@ -360,7 +360,7 @@ bpQualifiedName() == ++ ID ++ Name :: ID bpName() == - $stok is ["ID",:.] => + tokenClass $stok = "ID" => bpPushId() bpNext() bpAnyNo function bpQualifiedName @@ -375,12 +375,12 @@ bpName() == ++ QUOTE S-Expression ++ STRING bpConstTok() == - shoeTokType $stok in '(INTEGER FLOAT) => + tokenClass $stok in '(INTEGER FLOAT) => bpPush $ttok bpNext() - $stok is ["LISP",:.] => bpPush %Lisp $ttok and bpNext() - $stok is ["LISPEXP",:.] => bpPush $ttok and bpNext() - $stok is ["LINE",:.] => bpPush ["+LINE", $ttok] and bpNext() + tokenClass $stok = "LISP" => bpPush %Lisp $ttok and bpNext() + tokenClass $stok = "LISPEXP" => bpPush $ttok and bpNext() + tokenClass $stok = "LINE" => bpPush ["+LINE", $ttok] and bpNext() bpEqPeek "QUOTE" => bpNext() bpRequire function bpSexp and @@ -388,7 +388,7 @@ bpConstTok() == bpString() or bpFunction() bpChar() == - $stok is ["ID",:.] and $ttok is "char" => + tokenClass $stok = "ID" and $ttok is "char" => a := bpState() bpApplication() => s := bpPop1() @@ -538,8 +538,8 @@ bpCancel()== bpAddTokens n== n=0 => nil - n>0=> [shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),:bpAddTokens(n-1)] - [shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),:bpAddTokens(n+1)] + n>0=> [mk%Token("KEY","SETTAB",tokenPosition $stok),:bpAddTokens(n-1)] + [mk%Token("KEY","BACKTAB",tokenPosition $stok),:bpAddTokens(n+1)] bpExceptions()== bpEqPeek "DOT" or bpEqPeek "QUOTE" or @@ -549,17 +549,17 @@ bpExceptions()== bpSexpKey()== - $stok is ["KEY",:.] and not bpExceptions() => + tokenClass $stok = "KEY" and not bpExceptions() => a := $ttok has SHOEINF a = nil => bpPush keywordId $ttok and bpNext() bpPush a and bpNext() false bpAnyId()== - bpEqKey "MINUS" and ($stok is ["INTEGER",:.] or bpTrap()) and + bpEqKey "MINUS" and (tokenClass $stok = "INTEGER" or bpTrap()) and bpPush(-$ttok) and bpNext() or bpSexpKey() or - shoeTokType $stok in '(ID INTEGER STRING FLOAT) + tokenClass $stok in '(ID INTEGER STRING FLOAT) and bpPush $ttok and bpNext() bpSexp()== @@ -596,11 +596,11 @@ bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator()) bpDot()== bpEqKey "DOT" and bpPush bfDot () bpPrefixOperator()== - $stok is ["KEY",:.] and + tokenClass $stok = "KEY" and $ttok has SHOEPRE and bpPushId() and bpNext() bpInfixOperator()== - $stok is ["KEY",:.] and + tokenClass $stok = "KEY" and $ttok has SHOEINF and bpPushId() and bpNext() bpSelector()== @@ -636,8 +636,8 @@ bpTagged()== bpExpt()== bpRightAssoc('(POWER),function bpTagged) bpInfKey s == - $stok is ["KEY",:.] and - symbolMember?($ttok,s) and bpPushId() and bpNext() + tokenClass $stok = "KEY" and + symbolMember?($ttok,s) and bpPushId() and bpNext() bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true) @@ -660,7 +660,7 @@ bpLeftAssoc(operations,parser)== false bpString()== - shoeTokType $stok is "STRING" and + tokenClass $stok = "STRING" and bpPush(quote makeSymbol $ttok) and bpNext() bpFunction() == @@ -668,7 +668,7 @@ bpFunction() == and bpPush bfFunction bpPop1() bpThetaName() == - $stok is ["ID",:.] and $ttok has SHOETHETA => + tokenClass $stok = "ID" and $ttok has SHOETHETA => bpPushId() bpNext() false @@ -1098,7 +1098,7 @@ bpRegularBVItem() == or bpBracketConstruct function bpPatternL bpBVString()== - shoeTokType $stok is "STRING" and + tokenClass $stok = "STRING" and bpPush(["BVQUOTE",makeSymbol $ttok]) and bpNext() bpRegularBVItemL() == diff --git a/src/boot/pile.boot b/src/boot/pile.boot index fa19c102..f789067d 100644 --- a/src/boot/pile.boot +++ b/src/boot/pile.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2010, Gabriel Dos Reis. +-- Copyright (C) 2007-2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -38,19 +38,19 @@ namespace BOOTTRAN module pile shoeFirstTokPosn t == - shoeTokPosn CAAR t + tokenPosition CAAR t shoeLastTokPosn t== - shoeTokPosn second t + tokenPosition second t shoePileColumn t== - rest shoeTokPosn CAAR t + rest tokenPosition CAAR t -- s is a token-dq-stream shoePileInsert (s)== bStreamNull s => [[],:s] - toktype := shoeTokType CAAAR s + toktype := tokenClass CAAAR s toktype = "LISP" or toktype = "LINE" => [[first s],:rest s] a:=shoePileTree(-1,s) [[a.2],:a.3] @@ -104,11 +104,11 @@ shoePileCforest x== shoePileCoagulate(a,b)== b = nil => [a] c := first b - shoeTokPart CAAR c = "THEN" or shoeTokPart CAAR c = "ELSE" => + tokenValue CAAR c = "THEN" or tokenValue CAAR c = "ELSE" => shoePileCoagulate (dqAppend(a,c),rest b) d := second a - e := shoeTokPart d - d is ["KEY",:.] and + e := tokenValue d + tokenClass d = "KEY" and (e has SHOEINF or e = "COMMA" or e = "SEMICOLON") => shoePileCoagulate(dqAppend(a,c),rest b) [a,:shoePileCoagulate(c,rest b)] @@ -117,11 +117,11 @@ shoeSeparatePiles x== x = nil => [] rest x = nil => first x a := first x - semicolon := dqUnit shoeTokConstruct("KEY", "BACKSET",shoeLastTokPosn a) + semicolon := dqUnit mk%Token("KEY", "BACKSET",shoeLastTokPosn a) dqConcat [a,semicolon,shoeSeparatePiles rest x] shoeEnPile x== - dqConcat [dqUnit shoeTokConstruct("KEY","SETTAB",shoeFirstTokPosn x), + dqConcat [dqUnit mk%Token("KEY","SETTAB",shoeFirstTokPosn x), x, _ - dqUnit shoeTokConstruct("KEY","BACKTAB",shoeLastTokPosn x)] + dqUnit mk%Token("KEY","BACKTAB",shoeLastTokPosn x)] diff --git a/src/boot/scanner.boot b/src/boot/scanner.boot index 05a253a1..f283d08a 100644 --- a/src/boot/scanner.boot +++ b/src/boot/scanner.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2011, Gabriel Dos Reis. +-- Copyright (C) 2007-2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -60,22 +60,6 @@ dqToList s == s = nil => nil first s -shoeTokConstruct(x,y,z) == - [x,y,:z] - -shoeConstructToken(lp,b,n) == - shoeTokConstruct(b.0,b.1,[lp,:n]) - -shoeTokType x == - first x - -shoeTokPart x == - second x - -shoeTokPosn x == - [.,.,:p] := x - p - shoeNextLine s== bStreamNull s => false $linepos := s @@ -104,7 +88,7 @@ shoeLineToks s == $n = nil => shoeLineToks $r stringChar($ln,0) = char ")" => command := shoeLine? $ln => - dq := dqUnit shoeConstructToken($linepos,shoeLeafLine command,0) + dq := dqUnit makeToken($linepos,shoeLeafLine command,0) [[dq],:$r] command := shoeLisp? $ln => shoeLispToken($r,command) shoeLineToks $r @@ -120,7 +104,7 @@ shoeLispToken(s,string)== ln := $ln linepos := $linepos [r,:st] := shoeAccumulateLines(s,string) - dq := dqUnit shoeConstructToken(linepos,shoeLeafLisp st,0) + dq := dqUnit makeToken(linepos,shoeLeafLisp st,0) [[dq],:r] shoeAccumulateLines(s,string)== @@ -168,7 +152,7 @@ shoeToken() == [] shoeError() b = nil => nil - dqUnit shoeConstructToken(linepos,b,n) + dqUnit makeToken(linepos,b,n) -- to pair badge and badgee shoeLeafId x == diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index f087ddb7..7dce3190 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -27,7 +27,7 @@ (DEFUN |diagnosticLocation| (|tok|) (LET* (|pos|) (PROGN - (SETQ |pos| (|shoeTokPosn| |tok|)) + (SETQ |pos| (|tokenPosition| |tok|)) (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column " (WRITE-TO-STRING (|lineCharacter| |pos|)))))) @@ -40,7 +40,7 @@ (DEFUN |bpSpecificErrorAtToken| (|tok| |key|) (LET* (|a|) - (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|)))) + (PROGN (SETQ |a| (|tokenPosition| |tok|)) (|SoftShoeError| |a| |key|)))) (DEFUN |bpSpecificErrorHere| (|key|) (DECLARE (SPECIAL |$stok|)) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index fa16a127..53eb4f53 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -15,9 +15,9 @@ (SETQ |$stok| (COND ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|))) + (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|))) (T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (SETQ |$ttok| (|tokenValue| |$stok|)) T)) (DEFUN |bpFirstTok| () @@ -26,11 +26,11 @@ (SETQ |$stok| (COND ((NULL |$inputStream|) - (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|))) + (|mk%Token| 'ERROR 'NOMORE (|tokenPosition| |$stok|))) (T (CAR |$inputStream|)))) - (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (SETQ |$ttok| (|tokenValue| |$stok|)) (COND - ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY)) + ((AND (PLUSP |$bpParenCount|) (EQ (|tokenClass| |$stok|) 'KEY)) (COND ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|)) ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|)) @@ -243,16 +243,15 @@ (DEFUN |bpEqPeek| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|))) (DEFUN |bpEqKey| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|))) (DEFUN |bpEqKeyNextTok| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) - (|bpNextToken|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))) (DEFUN |bpPileTrap| () (|bpMissing| 'BACKTAB)) @@ -284,9 +283,9 @@ (DECLARE (SPECIAL |$stok|)) (PROGN (|bpFirstToken|) - (SETQ |pos1| (|shoeTokPosn| |$stok|)) + (SETQ |pos1| (|tokenPosition| |$stok|)) (|bpMoveTo| 0) - (SETQ |pos2| (|shoeTokPosn| |$stok|)) + (SETQ |pos2| (|tokenPosition| |$stok|)) (|bpIgnoredFromTo| |pos1| |pos2|) (|bpPush| (LIST (LIST "pile syntax error")))))) @@ -352,27 +351,26 @@ (DECLARE (SPECIAL |$stok|)) (COND ((|bpEqPeek| 'COLON-COLON) (|bpNext|) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) (|bpNext|) + (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|) (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) (T NIL))) (DEFUN |bpName| () (DECLARE (SPECIAL |$stok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) (|bpNext|) + ((EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|)) (T NIL))) (DEFUN |bpConstTok| () (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT)) + ((|symbolMember?| (|tokenClass| |$stok|) '(INTEGER FLOAT)) (|bpPush| |$ttok|) (|bpNext|)) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP)) + ((EQ (|tokenClass| |$stok|) 'LISP) (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP)) - (AND (|bpPush| |$ttok|) (|bpNext|))) - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE)) + ((EQ (|tokenClass| |$stok|) 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) + ((EQ (|tokenClass| |$stok|) 'LINE) (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) ((|bpEqPeek| 'QUOTE) (|bpNext|) (AND (|bpRequire| #'|bpSexp|) (|bpPush| (|bfSymbol| (|bpPop1|))))) @@ -382,7 +380,7 @@ (LET* (|ISTMP#1| |s| |a|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (EQ |$ttok| '|char|)) + ((AND (EQ (|tokenClass| |$stok|) 'ID) (EQ |$ttok| '|char|)) (SETQ |a| (|bpState|)) (COND ((|bpApplication|) (SETQ |s| (|bpPop1|)) @@ -496,10 +494,10 @@ (DECLARE (SPECIAL |$stok|)) (COND ((EQL |n| 0) NIL) ((PLUSP |n|) - (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|)) + (CONS (|mk%Token| 'KEY 'SETTAB (|tokenPosition| |$stok|)) (|bpAddTokens| (- |n| 1)))) (T - (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|)) + (CONS (|mk%Token| 'KEY 'BACKTAB (|tokenPosition| |$stok|)) (|bpAddTokens| (+ |n| 1)))))) (DEFUN |bpExceptions| () @@ -511,7 +509,7 @@ (LET* (|a|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|))) + ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions|))) (SETQ |a| (GET |$ttok| 'SHOEINF)) (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|))) (T (AND (|bpPush| |a|) (|bpNext|))))) @@ -520,11 +518,10 @@ (DEFUN |bpAnyId| () (DECLARE (SPECIAL |$ttok| |$stok|)) (OR - (AND (|bpEqKey| 'MINUS) - (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) (|bpTrap|)) + (AND (|bpEqKey| 'MINUS) (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap|)) (|bpPush| (- |$ttok|)) (|bpNext|)) (|bpSexpKey|) - (AND (|symbolMember?| (|shoeTokType| |$stok|) '(ID INTEGER STRING FLOAT)) + (AND (|symbolMember?| (|tokenClass| |$stok|) '(ID INTEGER STRING FLOAT)) (|bpPush| |$ttok|) (|bpNext|)))) (DEFUN |bpSexp| () @@ -559,13 +556,13 @@ (DEFUN |bpPrefixOperator| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) - (|bpPushId|) (|bpNext|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) + (|bpNext|))) (DEFUN |bpInfixOperator| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) - (|bpPushId|) (|bpNext|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) + (|bpNext|))) (DEFUN |bpSelector| () (AND (|bpEqKey| 'DOT) @@ -599,7 +596,7 @@ (DEFUN |bpInfKey| (|s|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|) (|bpPushId|) (|bpNext|))) (DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))) @@ -632,7 +629,7 @@ (DEFUN |bpString| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (AND (EQ (|tokenClass| |$stok|) 'STRING) (|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|))) (DEFUN |bpFunction| () @@ -642,8 +639,8 @@ (DEFUN |bpThetaName| () (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) - (|bpPushId|) (|bpNext|)) + ((AND (EQ (|tokenClass| |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) (|bpPushId|) + (|bpNext|)) (T NIL))) (DEFUN |bpReduceOperator| () @@ -1038,7 +1035,7 @@ (DEFUN |bpBVString| () (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (AND (EQ (|tokenClass| |$stok|) 'STRING) (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))) (DEFUN |bpRegularBVItemL| () diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp index 516327d2..6eb0c938 100644 --- a/src/boot/strap/pile.clisp +++ b/src/boot/strap/pile.clisp @@ -7,16 +7,16 @@ (PROVIDE "pile") -(DEFUN |shoeFirstTokPosn| (|t|) (|shoeTokPosn| (CAAR |t|))) +(DEFUN |shoeFirstTokPosn| (|t|) (|tokenPosition| (CAAR |t|))) -(DEFUN |shoeLastTokPosn| (|t|) (|shoeTokPosn| (CADR |t|))) +(DEFUN |shoeLastTokPosn| (|t|) (|tokenPosition| (CADR |t|))) -(DEFUN |shoePileColumn| (|t|) (CDR (|shoeTokPosn| (CAAR |t|)))) +(DEFUN |shoePileColumn| (|t|) (CDR (|tokenPosition| (CAAR |t|)))) (DEFUN |shoePileInsert| (|s|) (LET* (|a| |toktype|) (COND ((|bStreamNull| |s|) (CONS NIL |s|)) - (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|))) + (T (SETQ |toktype| (|tokenClass| (CAAAR |s|))) (COND ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE)) (CONS (LIST (CAR |s|)) (CDR |s|))) @@ -93,12 +93,12 @@ (COND ((NULL |b|) (LIST |a|)) (T (SETQ |c| (CAR |b|)) (COND - ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN) - (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE)) + ((OR (EQ (|tokenValue| (CAAR |c|)) 'THEN) + (EQ (|tokenValue| (CAAR |c|)) 'ELSE)) (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) - (T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|)) + (T (SETQ |d| (CADR |a|)) (SETQ |e| (|tokenValue| |d|)) (COND - ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY) + ((AND (EQ (|tokenClass| |d|) 'KEY) (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA) (EQ |e| 'SEMICOLON))) (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|))) @@ -110,15 +110,12 @@ (T (SETQ |a| (CAR |x|)) (SETQ |semicolon| (|dqUnit| - (|shoeTokConstruct| 'KEY 'BACKSET - (|shoeLastTokPosn| |a|)))) + (|mk%Token| 'KEY 'BACKSET (|shoeLastTokPosn| |a|)))) (|dqConcat| (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))) (DEFUN |shoeEnPile| (|x|) (|dqConcat| - (LIST (|dqUnit| (|shoeTokConstruct| 'KEY 'SETTAB (|shoeFirstTokPosn| |x|))) - |x| - (|dqUnit| - (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeLastTokPosn| |x|)))))) + (LIST (|dqUnit| (|mk%Token| 'KEY 'SETTAB (|shoeFirstTokPosn| |x|))) |x| + (|dqUnit| (|mk%Token| 'KEY 'BACKTAB (|shoeLastTokPosn| |x|)))))) diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp index 958f768b..3c056e11 100644 --- a/src/boot/strap/scanner.clisp +++ b/src/boot/strap/scanner.clisp @@ -23,19 +23,6 @@ (DEFUN |dqToList| (|s|) (COND ((NULL |s|) NIL) (T (CAR |s|)))) -(DEFUN |shoeTokConstruct| (|x| |y| |z|) (CONS |x| (CONS |y| |z|))) - -(DEFUN |shoeConstructToken| (|lp| |b| |n|) - (|shoeTokConstruct| (ELT |b| 0) (ELT |b| 1) (CONS |lp| |n|))) - -(DEFUN |shoeTokType| (|x|) (CAR |x|)) - -(DEFUN |shoeTokPart| (|x|) (CADR |x|)) - -(DEFUN |shoeTokPosn| (|x|) - (LET* (|p|) - (PROGN (SETQ |p| (CDDR |x|)) |p|))) - (DEFUN |shoeNextLine| (|s|) (LET* (|s1| |a|) (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|)) @@ -72,8 +59,7 @@ ((SETQ |command| (|shoeLine?| |$ln|)) (SETQ |dq| (|dqUnit| - (|shoeConstructToken| |$linepos| - (|shoeLeafLine| |command|) 0))) + (|makeToken| |$linepos| (|shoeLeafLine| |command|) 0))) (CONS (LIST |dq|) |$r|)) ((SETQ |command| (|shoeLisp?| |$ln|)) (|shoeLispToken| |$r| |command|)) @@ -97,9 +83,7 @@ (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|)) (SETQ |r| (CAR |LETTMP#1|)) (SETQ |st| (CDR |LETTMP#1|)) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0))) + (SETQ |dq| (|dqUnit| (|makeToken| |linepos| (|shoeLeafLisp| |st|) 0))) (CONS (LIST |dq|) |r|)))) (DEFUN |shoeAccumulateLines| (|s| |string|) @@ -146,8 +130,7 @@ ((CHAR= |ch| (|char| '_)) (|shoeEscape|)) ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL) (T (|shoeError|)))) - (COND ((NULL |b|) NIL) - (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|))))))) + (COND ((NULL |b|) NIL) (T (|dqUnit| (|makeToken| |linepos| |b| |n|))))))) (DEFUN |shoeLeafId| (|x|) (LIST 'ID (INTERN |x|))) diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp index d75c74a2..abb77212 100644 --- a/src/boot/strap/tokens.clisp +++ b/src/boot/strap/tokens.clisp @@ -6,12 +6,26 @@ (PROVIDE "tokens") (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) - (EXPORT '(|$InteractiveMode| |char|))) + (EXPORT '(|$InteractiveMode| |char| |subString|))) (DECLAIM (FTYPE (FUNCTION (|%Symbol|) |%Char|) |char|)) (DEFPARAMETER |$InteractiveMode| NIL) +(DEFSTRUCT (|%Token| (:COPIER |copy%Token|)) |cls| |val| |pos|) + +(DEFMACRO |mk%Token| (|cls| |val| |pos|) + (LIST '|MAKE-%Token| :|cls| |cls| :|val| |val| :|pos| |pos|)) + +(DEFMACRO |tokenClass| (|bfVar#1|) (LIST '|%Token-cls| |bfVar#1|)) + +(DEFMACRO |tokenValue| (|bfVar#1|) (LIST '|%Token-val| |bfVar#1|)) + +(DEFMACRO |tokenPosition| (|bfVar#1|) (LIST '|%Token-pos| |bfVar#1|)) + +(DEFUN |makeToken| (|lp| |b| |n|) + (|mk%Token| (CAR |b|) (CADR |b|) (CONS |lp| |n|))) + (DEFUN |char| (|x|) (SCHAR (SYMBOL-NAME |x|) 0)) (DEFUN |shoeStartsId| (|x|) diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot index b31eeec3..ac4d665a 100644 --- a/src/boot/tokens.boot +++ b/src/boot/tokens.boot @@ -34,12 +34,26 @@ import utility namespace BOOTTRAN -module tokens ($InteractiveMode, char) where +module tokens ($InteractiveMode, char, subString) where char: %Symbol -> %Char ++ If true, means the system is in interactive mode. $InteractiveMode := false +--% + +structure %Token == + Record(cls: %Symbol, val: %Thing, pos: %Position) with + tokenClass == (.cls) + tokenValue == (.val) + tokenPosition == (.pos) + +makeToken(lp,b,n) == + mk%Token(first b,second b,[lp,:n]) + + +--% + ++ converts `x', a 1-length symbol, to a character. char x == stringChar(symbolName x, 0) diff --git a/src/boot/utility.boot b/src/boot/utility.boot index 6032f24e..294f9d71 100644 --- a/src/boot/utility.boot +++ b/src/boot/utility.boot @@ -1,4 +1,4 @@ --- Copyright (C) 2011, Gabriel Dos Reis. +-- Copyright (C) 2012, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot index 7e4e738a..5a527962 100644 --- a/src/interp/sys-utility.boot +++ b/src/interp/sys-utility.boot @@ -339,12 +339,6 @@ writeByteToStreamSocket(s,b) == makeByteBuffer(n,b == 0) == MAKE_-ARRAY(n,KEYWORD::ELEMENT_-TYPE,"%Byte",KEYWORD::INITIAL_-ELEMENT,b) -++ return the sub-string of `s' starting from `f'. -++ When non-nil, `n' designates the length of the sub-string. -subString(s,f,n == nil) == - n = nil => subSequence(s,f) - subSequence(s,f,f + n) - ++ Return the position of the symbol `s' in the list `l', if present. ++ Otherwise return nil. symbolPosition(s,l) == |