nedoPC.org

Electronics hobbyists community established in 2002
Atom Feed | View unanswered posts | View active topics It is currently 29 Mar 2024 05:43



Reply to topic  [ 85 posts ]  Go to page Previous  1, 2, 3, 4, 5, 6  Next
RFORTH 
Author Message
Doomed
User avatar

Joined: 05 Nov 2007 05:08
Posts: 487
Location: Украина
Reply with quote
Lavr wrote:
добавил внутрь русификацию

месье! вы напрягаете мой склероз!
RFORTH изначально содержит кириллические имена слов.
Под русификацией я имел ввиду встроенный прямо в форт-систему кириллический шрифт и обработчик кодов клавиш, т.к. одно время мечтал записать его в расширение БИУСа ;)


17 May 2020 13:35
Profile WWW
Supreme God
User avatar

Joined: 21 Oct 2009 08:08
Posts: 7777
Location: Россия
Reply with quote
shoorick wrote:
Lavr wrote:
добавил внутрь русификацию
месье! вы напрягаете мой склероз!
Щаз ещё напрягу! Ты ж "старый фортер"! Кого ж еще спрашивать? :wink:

По ходу моей "пьесы" надо было адаптировать вот такой момент:
Attachment:
Leave.gif
Leave.gif [ 2.89 KiB | Viewed 5698 times ]

Но в Форте от Шихова слова Leave не было... :-?
И как я ни старался, реализовать Leave средствами Форта не смог... :osad:

Ты не знаешь, как это сделать? Именно средствами Форта, не трогая его код.


P.S. Ну и поскольку как устроен Форт внутри я немного проникся, а к Форту меня всегда приводит
мысль "нужен маленький ЯВУ для поделки с ограниченными ресурсами", стало мне зело интересно,
а как реализовывали Форт на бесстековых машинах, к примеру, на PDP-8...
И как ни странно, Форт для PDP-8 от какого-то умельца-фортера я вроде как нашел!
:roll:
Kyle Owen wrote:
Just a little bit of cursory looking turned up nothing. Has someone
written a Forth interpreter for PDP-8? Preferably using 24-bit
integers, but I'll take what I can get. OS/8 support would be nice.
Lars Brinkhoff wrote:
I recently wrote a Forth cross compiler with PDP-8 support.
https://github.com/larsbrinkhoff/xForth/tree/master/target/pdp8
Код на github я посмотрел, но, честно, не понял в нём нифига... :-?

_________________
iLavr


17 May 2020 13:43
Profile
Doomed
User avatar

Joined: 05 Nov 2007 05:08
Posts: 487
Location: Украина
Reply with quote
К форту я потерял интерес после того, как начал пытаться делать на нем что-то практическое. Падучесть очень высокая, выше чем у асма (если что - мое личное впечатление). Надо быть очень внимательным. Насчет выходов из цикла - не помню. Реализовать такое непросто. После выполнения слова DO в стеке хранится адрес возврата, который извлекает слово LOOP, чтобы записать в себя куда LOOP в начало цикла, a с технической точки зрения LEAVE сродни слову IF: IF помещает в стек адрес своего перехода, который ENDIF извлекает и записывает туда свой адрес - в результате, если условие не выполняется, происходит переход сразу в район ENDIF.
Т.е. нужно так переделать LOOP, чтобы оно позаписывало адрес на себя во все слова LEAVE внутри цикла - т.е. это возможно, но сложно, проще внутри цикла поставить условие. При этом следует иметь в виду, что все выравнивания стека внутри циклов и условий лежат на программисте - это вам не винапи, где винда перед возвратом еще и маркер свой в стеке проверяет - си-вызов был или паскаль? (не всегда, правда). Кстати слово типа REPEAT (переход сразу на начало цикла из его середины) сделать проще - это то же LOOP, только не удаляющее адрес начала цикола из стека (типо как ELSE - ELSE заменяет адрес IF в стеке на свой для ENDIF, а в IF записывает переход на себя).
Плюс (практически) невозможно размещать LEAVE внутри условий IF-ENDIF (и REPEAT, кстати, тоже), так как это нарушит их (условий IF-ENDIF) компиляцию. Хотя можно использовать вариант условного выхода или перехода в начало, типа, LEAVEIF или REPEATIF.
Форт штука гениальная, но компилятор близорукий.


17 May 2020 21:19
Profile WWW
Supreme God
User avatar

Joined: 21 Oct 2009 08:08
Posts: 7777
Location: Россия
Reply with quote
shoorick wrote:
Падучесть очень высокая, выше чем у асма (если что - мое личное впечатление). Надо быть очень внимательным.

Тут, честно говоря, соглашусь - падучесть очень высокая, и это потому, я считаю, что АСМ делает
только то, что ты написал. А FORTH еще сам что-то делает, и не всегда угадаешь, правильно ли он тебя
понял, и что он сделает. И - да, за стеками надо четко следить.


Насчет слова LEAVE пишут вот что:
Quote:
Реализация слова LEAVE в fig-Форте приравнивала счётчик цикла DO…LOOP к его границе,
в результате чего последующее слово LOOP не выполняло переход на очередной цикл DO.
Заметьте, что LEAVE немедленно завершает цикл. Никакие слова после LEAVE в
пределах цикла не будут выполнены.

Собственно говоря, это и понятно, в другом языке я бы вышел из цикла со счетчиком, задав ему
значение априори выше максимального.
Но в цикле DO…LOOP переменная цикла I (или J) доступны только на чтение.

С другой стороны Н.Шихов написал, что его словаря достаточно, чтобы сделать на этом Форте
любые другие слова Форта, поэтому хотелось сделать LEAVE средствами самогО Форта...

Хотя... я сейчас читаю исходник внимательно: оригинальных процедур в Форте немного, остальные
используют активно эти процедуры Форта плюс немного ассемблера.


P.S. И я тут разыскал исходник Форта для PDP-8 исторических времён, не новодел:
 FORTH COMPILER/INTERPRETER FOR TSS/8.24
Code:
/ ** FORTH-8 **
/FORTH COMPILER/INTERPRETER
/FOR TSS/8.24 PAL/D assembler
/STARTED 29-JUL-84
/BY JOHN WILSON.
/
*0
  JMP START
/BETCHA DIDN'T KNOW YOU COULD JUMP-START A PROGRAM!
/
FIXTAB  BSW=  7002
/
JUMP=  JMS I .
  JUMP0  /JUMP TO ADDRESS FOLLOWING JMS
CALL=  JMS I .
  CALL0  /CALL TO ADDR FOLLOWING JMS, USING STACK
RET=  JMP I .
  RET0  /POP VALUE OFF STACK, JUMP TO IT
RPUSH=  JMS I .
  RPUSH0  /PUSH AC TO RETURN STACK
RPOP=  JMS I .
  RPOP0  /POP RETURN STACK TO AC
PPUSH=  JMS I .
  PPUSH0  /PUSH AC TO PARAMETER STACK
PPOP=  JMS I .
  PPOP0  /POP PARAMETER STACK TO AC
*10
INDEX1,  0  /SCRATCH AUTO-INDEXING POINTER
INDEX2,  0
INDEX3,  0
/CONSTANTS:
C0007,  7
C0027,  27
C0077,  77
C0240,  240
C7540,  7540
*20
DP,  USRDCT  /DICTIONARY PTR
IMMDP,  ICODE  /DICT PTR INTO IMMEDIATE BUFFER
/
SP,  0  /RETURN STACK POINTER
PSP,  0  /PARAMETER STACK POINTER
NSP,  0  /NESTING STACK POINTER
/
/TEMPORARY VARIABLES:
TEMP1,  0
TEMP2,  0
TEMP3,  0
TEMP4,  0
TEMP5,  0
/
ERROR=  JMS I .
  ERROR0  /PRINT TRIMMED ASCII ERROR MESSAGE AFTER JMS, & ABORT
PPUSHC=  JMS I .
  PPC0  /PUSH CONSTANT AFTER JMS TO PARAMETER STACK
NPUSH=  JMS I .
  NPUSH0  /PUSH AC AND WORD AFTER JMS TO NESTING STACK
NPOP=  JMS I .
  NPOP0  /CHECK FOR MATCH WITH WORD AFTER JMS, POP AC FROM NSTACK
DCTVAL=  JMS I .
  DCTVA0  /PUT AC IN DICT (ONLY), AND ADVANCE DP
DCTCON=  JMS I .
  DCTCO0  /PUT WORD FOLLOWING JMS IN DICT, ADVANCE DP
PUTVAL=  JMS I .
  PUTVA0  /PUT AC IN CURRENT BUFFER, AND ADVANCE PTR
PUTCON=  JMS I .
  PUTCO0  /PUT WORD FOLLOWING JMS IN CURR BUFF, & ADVANCE PTR
TYPE=  JMS I .
  TYPE0  /TYPE .ASCIZ STRING FOLLOWING JMS
PRINT=  JMS I .
  PRINT0  /PRINT CHAR IN AC, UPDATE PRCOL
CRLF=  JMS I .
  CRLF0  /PRINT CR, LF
RTS=  JMP I .
  DOWORD  /DO NEXT WORD (RETURN FROM TSTRU'S)
RUNIMM=  JMS I .
  RUNIM0  /RUN IMMEDIATE CODE, IF ANY
CURRDP=  JMS I .
  CURRD0  /RETURN DP FOR CURRENT BUFFER (SELON INWORD)
IF=  JMS I .
WHILE=  JMS I .
UNTIL=  JMS I .
  JUMPZ  /PPOP, JUMP TO @PC IF ZERO
DO=  JMS I .
  DO0  /COPY TOP TWO ARGS ON PSTACK TO RSTACK
LOOP=  JMS I .
  LOOP0  /INC @RSP, LOOP IF NOT EQUAL TO @RSP+1, ELSE CLEAR RSTACK
/
/NESTING STACK TOKENS:
TIF=  1  /IF-ELSE-THEN
TBEGIN=  2  /BEGIN-UNTIL, BEGIN-WHILE-REPEAT, BEGIN-AGAIN
TWHILE=  3  /BEGIN-WHILE-REPEAT
TDO=  4  /DO-LOOP, DO-+LOOP, DO-/LOOP
/
PRCOL,  0  /CURRENT PRINTING COLUMN (FOR TABS)
KBFILE,  0  /<>0 -> REDIRECTING KB INPUT FROM CHANNEL 0 (LOAD)
INWORD,  0  /<>0 -> COMPILING A WORD (: ... ;)
NLEVEL,  0  /CURRENT NESTING LEVEL
CARETF,  0  /<>0 -> PRINT "^" UNDER LAST WORD READ ON ERROR
ERRCOL,  0  /ADDR OF BEGN OF LAST WORD READ FROM LINE (FOR "^" ON ERR)
PROMPT,  0  /<>0 -> PROMPT WITH "OK" (ONLY IF THINGS ARE OKAY!)
DELFLG,  0  /<>0 -> BETWEEN \'S (ON INPUT)
LINPTR,  LINE  /PTR TO NEXT WORD IN LINE
/
M0211,  -211
WORDM1,  WORD-1
CLINE,  LINE
CWORD,  WORD
LOOKUP,  LOOKU0  /PTR TO LOOKUP ROUTINE
MAKEW,  MAKEW0  /PTR TO ROUTINE TO BUILD A WORD HEADER
GETWRD,  GETW  /PTR TO ROUTINE TO READ A WORD FROM THE KB
SMUDGE,  0  /PTR TO LINK TO LAST CREATED WORD (ZEROED ON ERR)
/
/INITIALIZE POINTERS, SET ^C VECTOR
  CTRLC  /^C VECTOR
START,  CLA+400    /=7600 (RSTACK/PSTACK BOUNDARY)
  TAD .-2    /GET ^C VECTOR
  SRA    /SET IT
  UND    /TURN OFF ECHO
  STA    /SET KB BREAK
  KSB    /TO ANYTHING
  TYPE    /PRINT "FORTH-8 BY JOHN WILSON"
  "F;"O+40;"R+40;"T+40;"H+40;"-;"8;240;240 /KINKY LOWER CASE
  "B+40;"Y+40;240;"J;"O+40;"H+40;"N+40;240
  "W;"I+40;"L+40;"S+40;"O+40;"N+40
  215;212;0  /CR,LF,<NUL>
/
RESET,  TAD START  /LOAD 7600
  DCA PSP    /SET PSTACK PTR
CTRLC,  CLA    /JUMP HERE ON ^C
  DCA I LINPTR  /FORCE KB READ ON NEXT GETW
  TAD ICODE0  /GET PTR TO IMM CODE
  DCA IMMDP  /POKE IT TO PTR
  DCA NSP    /SET NSTACK PTR
  DCA SP    /SET RSTACK PTR
  IAC    /SET BIT FOR CHAN 0 (KB REDIRECTION)
  ISZ KBFILE  /REDIRECTING INPUT?
  SKP CLA    /NO, DON'T WASTE FIP'S TIME
  CLOS    /YES, CLOSE THE FILE
  DCA KBFILE  /ANYWAY, WE'RE NOT NOW
  TAD SMUDGE  /KILL LAST WORD?
  SNA CLA
  JMP .+5    /NO, CONTINUE
  TAD I SMUDGE  /YES, GET LINK TO CONDEMNED WORD
  DCA DP    /BACK UP DP
  DCA I SMUDGE  /CLEAR OUT THE LINK
  DCA SMUDGE  /DON'T DO THIS AGAIN
  DCA NLEVEL  /CLEAR NESTING LEVEL
  CMA    /PRINT "^" UNDER ERRORS
  DCA CARETF
  DCA INWORD  /NOT IN A WORD (: DEF'N)
/THAT SHOULD DO IT - NOW START THE INTERPRETER
  JMP I .+1
C0200,  DOWORD    /JUMP INTO LOOP
ICODE0,  ICODE  /BEGN OF IMMEDIATE CODE
/
PAGE
/
DOWORD,  /GET AND COMPILE A WORD
  JMS GETW  /GET A WORD
  JMS I LOOKUP  /LOOK UP THE WORD
  SZL    /SKIP IF FOUND
  JMP DOWOR1  /NOT FOUND, MAYBE IT'S A #
  TAD I TEMP1  /GET TYPE
  DCA TEMP2  /SAVE
  ISZ TEMP1  /INC PTR
  JMP I TEMP2  /TYPE IS ALSO VECTOR
TCONS,  /CONSTANT
  TAD I TEMP1  /GET VALUE
  DCA TEMP1  /SAVE AS ADDR (FAKE OUT TVARI)
TVARI,  /VARIABLE
  PUTCON    /COMPILE A PPUSHC
  PPUSHC    /THAT'S WHAT I SAID
  TAD TEMP1  /GET ADDR (VALUE IF TCONS)
  PUTVAL    /COMPILE IT IN-LINE
  JMP DOWORD  /LOOP
TSUBR,  /SUBROUTINE (: ... ;)
  PUTCON    /COMPILE A CALL
  CALL    /YEP
  TAD TEMP1  /GET ADDR
  PUTVAL    /LOOKS AN AWFUL LOT LIKE TVARI!
  JMP DOWORD  /LOOP
TSTRU,  /CONTROL STRUCTURE (DO-LOOP, IF-ELSE-THEN, ETC.)
  JMP I TEMP1  /JUMP TO COMPILATION ROUTINE
/CONTROL STRUC ROUTINES RETURN VIA "RTS" (JMP I (DOWORD))
DOWOR1,  /WORD NOT DEFINED, CHECK FOR NUMBER
  TAD CWORD  /POINT AT WORD
  DCA TEMP1  /SAVE PTR
  JMS NUM    /SEE IF NUMBER
  SNL    /NO, ERROR
  JMP DOWOR2  /YES, VALUE IS IN TEMP2, GO PPUSHC IT
  ERROR    /UNDEFINED WORD
  TEXT /WHAT?/  /I JUST LOVE VAGUE MESSAGES!
DOWOR2,  PUTCON    /PPUSHC
  PPUSHC    /...
  TAD TEMP2  /GET VAL BACK
  PUTVAL    /COMPILE IN-LINE
  JMP DOWORD  /DO ANOTHER WORD
/
NUM,  0  /CONVERT .ASCIZ NUMBER AT @TEMP1 TO BINARY
/RESULT IN TEMP2, LINK SET IF NOT VALID NUMBER.
  DCA TEMP2  /CLEAR ACCUMULATOR
  DCA TEMP3  /CLEAR NEGATIVE FLAG
  TAD I TEMP1  /GET FIRST CHAR
  TAD MMINUS  /"-" ?
  SZA CLA    /SKIP IF SO
  JMP NUM1  /NO
  ISZ TEMP3  /SET FLAG
  ISZ TEMP1  /INC PTR
NUM1,  TAD I TEMP1  /GET A CHAR
  SNA    /SKIP IF NOT DONE
  JMP NUM2  /DONE, WHEE!
  TAD NUM4  /MOVE TO RANGE [-10,-1]
  CLL
  TAD C0012  /FLIP LINK IF VALID DECIMAL
  SNL    /SKIP IF HOOPY
  JMP NUM3  /INVALID DIGIT - NOT A NUMBER
  DCA TEMP4  /SAVE
  TAD TEMP2  /GET OLD NUMBER
  CLL RTL    /*4
  TAD TEMP2  /+NUMBER
  CLL RAL    /*2 =(((N*4)+N)*2)=N*10.
  TAD TEMP4  /ADD IN NEW DIGIT
  DCA TEMP2  /REPLACE
  ISZ TEMP1  /INC PTR
  JMP NUM1  /LOOP
NUM2,  TAD TEMP3  /NEGATE?
  SNA CLA
  JMP .+4    /NO, SKIP
  TAD TEMP2  /GET NUMBER
  CIA    /NEGATE
  DCA TEMP2  /REPLACE
  CLL    /CLEAR LINK - VALID NUMBER
  JMP I NUM  /RETURN WITH VALUE IN TEMP2
NUM3,  STL    /NOT A NUMBER
  JMP I NUM  /RETURN
NUM4,  -12-"0
C0012,  12
MMINUS,  -"-
/
GETW,  0
/READ A WORD FROM @LINPTR TO FIRST CTRL CHAR OR SPACE
/ENTER WITH AC CLEAR
/RETURN WITH .ASCIZ STRING IN WORD
  TAD WORDM1  /PT AT WORD (AX)
  DCA INDEX1  /OUTPUT PTR
GETW1,  TAD LINPTR  /SET ERRCOL TO POINT HERE
  DCA ERRCOL  /IN CASE THIS IS A NASTY WORD
  TAD I LINPTR  /GET CHAR
  SNA    /END OF LINE?
  JMP I READLN  /YES, GET ANOTHER ONE
  TAD M0241  /SPACE OR CTRL CHAR?
  SMA
  JMP GETW2  /NO
  IAC    /SPACE?
  SZA
  TAD C0027  /TAB?
  SZA CLA    /YES, ONE OR THE OTHER
  JMP .+3    /NO, ILLEGAL CHAR
  ISZ LINPTR  /INC PTR (IGNORE)
  JMP GETW1  /LOOP
  ERROR    /ILLEGAL CHAR
  TEXT /ILL CHAR/
GETW2,  CLA
GETW3,  TAD I LINPTR  /GET CHAR
  TAD M0241  /CTRL CHAR OR SPACE?
  SPA CLA
  JMP GETW4  /YES, GO RETURN
  TAD I LINPTR  /NO, RESTORE CHAR
  TAD C7405  /CVT LOWER CASE TO [-26.,-1]
  CLL
  TAD C0032  /LOWER CASE?
  SZL CLA    /NO, SKIP
  TAD M0040  /YES, SUBTRACT 32.
  TAD I LINPTR  /GET CHAR BACK
  DCA I INDEX1  /SAVE
  ISZ LINPTR  /INC PTR
  JMP GETW3  /LOOP
GETW4,  DCA I INDEX1  /MARK END WITH <NUL>
  JMP I GETW  /RETURN
M0241,  -241  /SPACE, CTRL CHARS -> [-32.,-1]
C0032,  32  /[-26.,-1] -> [0,25.] (FLIPPING LINK)
C7405,  7405  /LOWER CASE -> [-26.,-1]
M0040,  -40  /LOWER CASE -> UPPER CASE
READLN,  READL0  /PROMPT, GET A LINE
/
PAGE
/
READL0,  /CALLS INPUT, AND RESETS LINPTR
  RUNIMM    /RUN IMMEDIATE CODE FIRST
  TAD PROMPT  /PROMPT?
  SNA CLA
  JMP READL1  /NO
  TYPE    /YES, PRINT PROMPT
  "O+40;"K+40;215;212;0  /"OK<CR><LF>" (LOWER CASE)
READL1,  CMA    /REMEMBER TO PROMPT NEXT TIME, ANYWAY
  DCA PROMPT
  TAD CLINE  /PT AT LINE BUFFER
  DCA TEMP1  /PUT IN TEMP1
  JMS INPUT  /READ A LINE
  TAD CLINE  /GET PTR TO LINE
  DCA LINPTR  /PT AT LINE
  JMP I .+1  /TRY AGAIN
  GETW+1
/
INPUT,  0  /READ 80 CHARS FROM TTY TO @TEMP1
/ENTER WITH AC CLEAR
/0 MARKS END OF INPUT STRING
  TAD TEMP1  /GET START OF BUFFER
  CIA    /NEGATE
  DCA TEMP2  /USED TO CHECK BEG OF BUFF ON RUBOUT
  TAD TEMP1  /GET PTR
  DCA INDEX2  /SAVE IT
  TAD TEMP1  /GET START OF BUFFER
  TAD D0080  /PT AT LAST NON-CR CHAR IN BUFFER
  CIA    /NEGATE
  DCA TEMP3  /USED TO CHECK END OF BUFF ON INSERT
  DCA DELFLG  /NOT BETWEEN \'S
INPUT1,  KRB    /GET A CHAR
  DCA TEMP4  /SAVE IT
  TAD NUMSPC  /-(NUMBER OF SPECIALLY TREATED CHARS)
  DCA TEMP5  /LOOP CTR
  TAD CIDISP  /PT AT IDISP (DISP. TABLE)
  DCA INDEX1  /SAVE
  TAD TEMP4  /GET CHAR BACK
INPUT2,  TAD I INDEX1  /IS THIS THE CHAR?
  SNA    /SKIP IF THIS ISN'T IT
  JMP INPUT5  /THIS IS IT, GO JUMP TO IT
  ISZ INDEX1  /SKIP OVER ADDR
  ISZ TEMP5  /DONE?
  JMP INPUT2  /NO, TRY NEXT VALUE
  CLA
INPUT3,  /INSERT AND ECHO CHAR
  JMS BACKSL  /PRINT \ AND CLEAR DELFLG IF DELFLG
  TAD TEMP1  /GET PTR
  TAD TEMP3  /OUT OF SPACE?
  SZA CLA    /SKIP IF SO
  JMP INPUT4  /OTHERWISE CONTINUE
  TAD C0007  /RING BELL
  PRINT
  JMP INPUT1  /AND IGNORE
INPUT4,  TAD TEMP4  /GET CHAR
  DCA I TEMP1  /PUT IN BUFFER
  ISZ TEMP1  /INC PTR
  JMS I ECHOA  /ECHO THE CHAR
  JMP INPUT1  /LOOP
INPUT5,  /JUMP TO DISPATCH TABLE ADDRESS
  CLA    /CLEAR AC
  TAD I INDEX1  /GET DISPATCH VALUE
  DCA BACKSL  /SAVE
  JMP I BACKSL  /JUMP TO IT
BACKSL,  0  /IF DELFLG.NE.0, PRINT \ AND CLEAR DELFLG
  TAD DELFLG  /INSIDE \'S?
  SNA CLA
  JMP I BACKSL  /NO, RETURN
  DCA DELFLG  /CLEAR FLAG
  TAD .+3    /LOAD "\"
  PRINT    /PRINT IT
  JMP I BACKSL  /AND RETURN
  "\    /DELIMITS DELETED CHAR'S
INPUT6,  /MARK END OF STRING AND RETURN
  JMS BACKSL  /"\" IF NESSA
  DCA I TEMP1  /ZERO AT END
  CRLF    /CR,LF
  JMP I INPUT  /RETURN
INPUT7,  /^R - CR,LF AND REDRAW STRING
  JMS BACKSL  /"\" IF NESSA
  JMS I ECHOA  /PRINT "^R"
  CRLF    /CR,LF
  DCA I TEMP1  /MARK END OF STRING, FOR NOW
  CMA    /LOAD -1
  TAD INDEX2  /PT AT START OF STRING -1
  DCA INDEX3  /SAVE
INPUT8,  TAD I INDEX3  /GET A CHAR
  SNA    /SKIP IF NOT ZERO
  JMP INPUT1  /GET ANOTHER CHAR
  DCA TEMP4  /SAVE THE CHAR
  JMS I ECHOA  /ECHO IT
  JMP INPUT8  /LOOP UNTIL 0
INPUT9,  /^U - CR,LF AND CANCEL STRING
  JMS I ECHOA  /PRINT "^U"
  CRLF    /CR,LF
  TAD INDEX2  /GET START OF BUFFER
  DCA TEMP1  /RESET POINTER
  JMP INPUT1  /GET ANOTHER CHAR
  "$
INPU10,  /ESCAPE - ECHO $ AND RETURN
  JMS BACKSL  /"\" IF NESSA
  TAD .-2    /GET "$"
  PRINT    /PRINT IT
  DCA I TEMP1  /MARK END OF STRING
  JMP I INPUT  /AND RETURN
/
RUBOUT,  /RUBOUT - PRINT "\" (IF NESSA) AND ECHO LAST CHAR
  TAD TEMP1  /GET PTR
  TAD TEMP2  /GET -(START)
  SZA CLA    /BUFFER EMPTY?
  JMP RUB1  /NO
  JMS BACKSL  /PRINT CLOSING \ IF NESSA
  CRLF    /YES, CR,LF
  JMP INPUT1  /AND IGNORE
RUB1,  TAD DELFLG  /NEED A "\" ?
  SZA CLA
  JMP RUB2  /NO, ALREADY INSIDE \'S
  TAD INPUT6-1  /GET \
  PRINT    /PRINT IT
  ISZ DELFLG  /SET DELFLG
RUB2,  CMA    /BACK UP PTR
  TAD TEMP1
  DCA TEMP1
  TAD I TEMP1  /GET CHAR TO BE DELETED
  DCA TEMP4  /PUT IN CHAR BUFF
  JMS I ECHOA  /ECHO IT
  TAD TEMP1  /AT BEGN OF BUFF NOW?
  TAD TEMP2
  SZA CLA
  JMP INPUT1  /NO, LOOP
  JMS BACKSL  /PRINT "\"
  CRLF    /CR,LF
  JMP INPUT1  /AND DO ANOTHER CHAR
ECHOA,  ECHO  /PTR TO ECHO ROUTINE
D0080,  120  /80. (LENGTH OF BUFFER)
NUMSPC,  -13  /-(NUMBER OF SPECIAL INPUT CHARS)
CIDISP,  IDISP-1  /PTR TO INPUT DISPATCH TABLE
/
PAGE
/
ECHO,  0  /ECHO CHAR IN TEMP4
  TAD TEMP4  /GET CHAR
  AND C7540  /CLEAR AC4,AC7-AC11
  SNA CLA    /CTRL CHAR?
  JMP ECHO2  /YES, SPECIAL TREATMENT
ECHO1,  TAD TEMP4  /GET CHAR
  PRINT    /PRINT IT
  JMP I ECHO  /RETURN
ECHO2,  TAD TEMP4  /GET CHAR
  TAD M0211  /TAB?
  SZA    /SKIP IF SO
  IAC    /BACKSPACE?
  SNA CLA    /SKIP IF NOT
  JMP ECHO1  /HT & BS ARE ECHOED AS-IS
  TAD UPARR  /PRINT "^"
  PRINT
  7203    /CLA IAC BSW (PAL-D BUG) LOAD 64.
  TAD TEMP4  /LOAD CHAR+64.
  PRINT    /ECHO IT
  JMP I ECHO  /RETURN
UPARR,  "^  /FOR CTRL CHARS
/
/DISPATCH TABLE FOR SPECIAL CHARACTERS:
IDISP,  /INPUT DISPATCH TABLE (RO,ESC,^U,^R,^M,^L,^K,^J,^I,^H,NUL)
  -377  /RUBOUT
  RUBOUT
  377-233  /ESCAPE
  INPU10
  233-225  /^U
  INPUT9
  225-222  /^R
  INPUT7
  222-215  /CR
  INPUT6
  215-214  /FF
  INPUT6
  214-213  /VT
  INPUT6
  213-212  /LF
  INPUT6
  212-211  /TAB
  INPUT3
  211-210  /BACKSPACE
  INPUT3
  210-200  /NUL
  INPUT1
/DWEE!
/
  0  /TEMP BUFFER FOR CHAR
PRINT0,  0  /PRINT CHAR IN AC, DEAL WITH TABS
  DCA PRINT0-1  /SAVE
  TAD PRINT0-1  /GET BACK
  TAD M0211  /TAB?
  SNA
  JMP TAB    /YES, DEAL WITH IT
  IAC    /BACKSPACE?
  SNA    /NO, SKIP
  JMP BCKSPC  /YES, SPECIAL TREATMENT
  TAD C7773  /CR?
  SNA CLA
  JMP CARRET  /YES
  TAD PRINT0-1  /GET CHAR
  AND C7540  /CTRL CHAR?
  SZA CLA    /SKIP IF SO
  ISZ PRCOL  /OTHERWISE INC PRCOL
PRINT1,  TAD PRINT0-1  /GET CHAR
  TLS    /PRINT IT
  CLA    /CLEAR AC
  JMP I PRINT0  /RETURN
/
BCKSPC,  CLL CMA    /DEC PRCOL
  TAD PRCOL
  SZL    /UNLESS IT'S ALREADY 0 (DEC TERMINALS)
  DCA PRCOL
  CLA    /IN CASE WE JUST SKIPPED
  JMP PRINT1  /PRINT BS AND RETURN
TAB,  TAD C0240  /PRINT A SPACE
  TLS
  CLA
  ISZ PRCOL  /MOVE OVER A COL
  TAD PRCOL  /GET PRCOL
  AND C0007  /AT A TAB STOP?
  SZA CLA    /SKIP IF SO
  JMP TAB    /ELSE LOOP
  JMP I PRINT0  /RETURN
CARRET,  DCA PRCOL  /CLEAR PRINT COLUMN
  JMP PRINT1  /PRINT CR AND RETURN
/
C7773,  7773
/
CRLF0,  0  /PRINT CR,LF
  TYPE    /A LITTLE SLOW, BUT SO WHAT?
  215;212;0  /CR,LF
  JMP I CRLF0  /RETURN
/
TYPE0,  0  /PRINT .ASCIZ STRING FOLLOWING "TYPE"
  TAD I TYPE0  /GET CHAR
  ISZ TYPE0  /INC PTR
  SNA    /DONE YET?
  JMP I TYPE0  /YES, RETURN
  PRINT    /NO, PRINT THE CHAR
  JMP TYPE0+1  /LOOP UNTIL 0
/
RPUSH0,  0  /PUSH AC TO RETURN STACK (7600-7777)
  DCA TYPE0  /SAVE AC
  TAD SP    /GET SP
  TAD C0200  /STACK FULL?
  SZA CLA
  JMP RPUSH1  /NO, GO PUSH
  ERROR    /YES, PRINT MESSAGE
  TEXT /RSTACK OVERFLOW/
RPUSH1,  CMA    /DEC SP
  TAD SP
  DCA SP
  TAD TYPE0  /GET AC BACK
  DCA I SP  /PUSH IT
  JMP I RPUSH0  /RETURN
/
PAGE
/
ERROR0,  0  /PRINT TRIMMED ASCII MESSAGE AFTER JMS & ABORT
  TAD CARETF  /PRINT "^"?
  SNA CLA
  JMP ERROR3  /NO
  TAD ERRCOL  /GET COLUMN OF ERROR
  CIA    /NEGATE
  DCA TEMP1  /SAVE
  TAD CLINE  /PT AT LINE
  DCA TEMP2  /SAVE
ERROR1,  TAD TEMP1  /DONE?
  TAD TEMP2
  SNA CLA
  JMP ERROR2  /YES, GO PRINT "^ "
  TAD I TEMP2  /GET CHAR
  TAD M0211  /TAB?
  SZA CLA
  TAD C0027  /NO, PRINT A SPACE
  TAD C0211  /YES, PRINT A TAB
  PRINT    /HACK, HACK, HACK
  ISZ TEMP2  /INC PTR
  JMP ERROR1  /LOOP
ERROR2,  TYPE    /PRINT "^ "
  "^;" ;0
ERROR3,  STA CLL RAL  /LOAD -2
  DCA RPOP0  /SAVE LOOP CTR
  TAD I ERROR0  /GET CHAR
  BSW    /GET HIGH CHAR
ERROR4,  AND C0077  /MASK OUT HIGH BITS
  SNA    /DONE?
  JMP ERROR6  /YES, CR/LF AND RESTART
  DCA LOOKU0  /NO, SAVE THE CHAR
  TAD LOOKU0  /GET BACK
  CMA    /FLIP EVERYTHING
  AND C0040  /BIT 6 SET?
  CLL RAL    /HACK HACK HACK
  TAD C0200  /ADD MISSING BITS
  TAD LOOKU0  /GET CHAR BACK
  PRINT    /PRINT IT
  ISZ RPOP0  /WAS THAT THE HIGH OR THE LOW CHAR?
  JMP ERROR5  /HIGH
  ISZ ERROR0  /LOW - PT TO NEXT CHAR
  JMP ERROR3  /DO THE NEXT TWO CHARS
ERROR5,  TAD I ERROR0  /GET LOW CHAR
  JMP ERROR4  /PRINT IT
ERROR6,  CRLF    /CR,LF
  DCA PROMPT  /NOT "OK"
  JMP RESET  /GO RESTART
C0040,  40
C0211,  211  /TAB
/
LOOKU0,  0  /LOOK UP WORD IN WORD BUFFER
/RETURN WITH LINK CLEAR AND TEMP1 POINTING AT TYPE IF
/FOUND, OR WITH LINK SET IF NOT FOUND.
  TAD CDICT  /PT AT DICT
  DCA TEMP1
  DCA TEMP2  /PTR TO LAST LINK (FORGET)
LOOKU1,  TAD WORDM1  /#WORD -1
  DCA INDEX1  /SOURCE PTR (AX)
LOOKU2,  CMA CLL RAL  /LOAD -2 (2 CH'S/WORD)
  DCA TEMP3  /LOOP CTR
  TAD I TEMP1  /GET 2 CHARS
  BSW    /LOOK AT HIGH ORDER FIRST
LOOKU3,  AND C0077  /REMOVE HIGH CHAR
  SNA    /END OF ENTRY?
  JMP LOOKU5  /YES, SEE IF END OF WORD
  TAD C0240  /CVT TO ASCII
  CIA    /NEGATE
  TAD I INDEX1  /=?
  SZA CLA
  JMP LOOKU6  /NO, SKIP TO LINK
  ISZ TEMP3  /FINISHED WORD?
  JMP LOOKU4  /NO, CHECK LOW CHAR
  ISZ TEMP1  /YES, PT AT NEXT PAIR OF CHARS
  JMP LOOKU2  /LOOP
LOOKU4,  TAD I TEMP1  /GET PAIR OF CHARS BACK
  JMP LOOKU3  /CHECK LOW CHAR
LOOKU5,  TAD I INDEX1  /END OF WORD?
  SZA CLA
  JMP LOOKU6  /NO, SKIP TO NEXT ENTRY
  ISZ TEMP1  /YES, PT AT LINK
  ISZ TEMP1  /PT AT TYPE
  CLL    /SIGNIFY FOUND
  JMP I LOOKU0  /RETURN
LOOKU6,  TAD I TEMP1  /GET CHAR
  ISZ TEMP1  /PT AT NEXT CHAR OR LINK
  AND C0077  /BOTTOM BYTE SHOULD BE 0, ANYWAY
  SZA CLA    /IS IT?
  JMP LOOKU6  /NO, TRY NEXT WORD
  TAD TEMP1  /YES, GET PTR TO LINK
  DCA TEMP2  /SAVE IN CASE OF <FORGET>
  TAD I TEMP1  /GET LINK
  STL    /IN CASE THIS IS THE END OF THE DICT
  SNA    /IS IT?
  JMP I LOOKU0  /YES, RETURN, LINK SET
  DCA TEMP1  /NO, PT TO NEXT NAME FIELD
  JMP LOOKU1  /CHECK THIS ENTRY
CDICT,  DICT  /BEGINNING OF DICTIONARY
/
DCTVA0,  0  /PUT AC IN DICTIONARY, ADVANCE DP (CHECK PSTACK)
  DCA I DP  /THERE IS ALWAYS AT LEAST 1 FREE WORD
  TAD DP    /GET DP
  CMA    /NEGATE, SUBTRACT 1 (HACK HACK)
  TAD PSP    /PSTACK COLLISION?
  SZA CLA
  JMP DCTVA1  /NO
  ERROR    /YES, ERROR
  TEXT /DICT FULL/
DCTVA1,  ISZ DP    /ALL OK, INC DP
  JMP I DCTVA0  /RETURN, AC CLEAR
/
DCTCO0,  0  /PUT WORD AFTER JMS IN DICT, ADVANCE DP
  CLA
  TAD I DCTCO0  /GET WORD TO PUT
  JMS DCTVA0  /PUT IT IN THE DICT
  ISZ DCTCO0  /PT PAST ARG
  JMP I DCTCO0  /RETURN, AC CLEAR
/
PAGE
/
MAKEW0,  0  /CREATE ENTRY FOR WORD IN WORD BUF IN DICT
/FIRST, CHECK TO MAKE SURE THE WORD DOESN'T ALREADY EXIST.
/USE TYPE IN WORD FOLLOWING JMS.
  JMS I LOOKUP  /TRY TO LOOK THE WORD UP
  SZL    /SKIP IF FOUND
  JMP MAKEW1  /NOT THERE, MAKE IT
  ERROR    /ALREADY DEFINED
  TEXT /ILL REDEF'N/
MAKEW1,  TAD TEMP2  /GET PTR TO LINK IN LAST ENTRY
  DCA SMUDGE  /SAVE IN CASE OF COMPILATION ERROR
  TAD WORDM1  /PT AT WORD
  DCA INDEX1  /SOURCE PTR
MAKEW2,  CMA CLL RAL  /-2
  DCA TEMP1  /LOOP CTR
MAKEW3,  TAD I INDEX1  /GET A CHAR
  SNA    /END?
  JMP MAKEW6  /YES, FINISH OFF
  TAD M0240  /NO, CVT TO SIXBIT
  DCA TEMP2  /SAVE
  TAD TEMP2  /CHECK
  AND C7700  /ANY EXTRA BITS?
  SNA CLA
  JMP MAKEW4  /OK, CONTINUE
  ERROR    /ILLEGAL NAME
  TEXT /ILL NAME/
MAKEW4,  TAD TEMP2  /GET CHAR
  ISZ TEMP1  /CHAR 1, OR 2?
  JMP MAKEW5  /1
  TAD TEMP3  /2 - GET OLD CHAR
  DCTVAL    /COMPILE INTO DICTIONARY
  JMP MAKEW2  /LOOP
MAKEW5,  BSW    /LEFT 6 BITS
  DCA TEMP3  /SAVE
  JMP MAKEW3  /LOOP
MAKEW6,  /END OF WORD
  ISZ TEMP1  /CHAR 1, OR 2?
  SKP    /1 - PUT 0,0
  TAD TEMP3  /2 - PUT CHAR,0
  DCTVAL    /COMPILE LAST WORD OF NAME
  DCTVAL    /LINK IS 0
  TAD I MAKEW0  /GET TYPE
  DCTVAL    /COMPILE IT
  ISZ MAKEW0  /SKIP OVER TYPE
  JMP I MAKEW0  /RETURN
C7700,  7700  /CLEAR OUT CHAR
M0240,  -240  /CONVERT ASCII TO SIXBIT
/
PUTVA0,  0  /PUT AC IN DICT OR IMMBUF, DEPENDING ON INWORD
  DCA MAKEW0  /SAVE AC
  TAD INWORD  /IN A : DEFN?
  SNA CLA    /SKIP IF SO
  JMP PUTVA1  /ELSEWISE, GO PUT IN ICODE
  TAD MAKEW0  /GET AC
  DCTVAL    /SAVE IN DICT
  JMP I PUTVA0  /RETURN
PUTVA1,  TAD IMMDP  /GET IMMEDIATE PSEUDO-DICTIONARY PTR
  TAD PUTVA3  /ICODE FULL?
  SZA CLA    /YES, ERROR
  JMP PUTVA2  /NO, POKE THE VALUE
  ERROR
  TEXT /IMM BUFF FULL/
PUTVA2,  TAD MAKEW0  /GET AC
  DCA I IMMDP  /PUT IN ICODE
  ISZ IMMDP  /INC PTR
  JMP I PUTVA0  /RETURN
PUTVA3,  -ICODE-176  /ALWAYS LEAVE ONE EXTRA WORD FOR "RET"
/
PUTCO0,  0  /PUT WORD AFTER JMS IN APPROPRIATE BUFFER
  CLA
  TAD I PUTCO0  /GET WORD
  JMS PUTVA0  /POKE TO BUFFER
  ISZ PUTCO0  /INC PTR
  JMP I PUTCO0  /RETURN
/
JUMP0,  0  /JUMP TO ADDR AFTER JMS
  CLA
  TAD I JUMP0  /GET ADDR
  DCA JUMP0  /SAVE
  JMP I JUMP0  /JUMP TO IT
/
CALL0,  0  /CALL ADDR FOLLOWING "CALL," USING RSTACK
  CLA IAC    /LOAD 1
  TAD CALL0  /RETURN ADDRESS
  RPUSH    /PUSH TO RSTACK
  TAD I CALL0  /GET ADDR TO CALL
  DCA CALL0  /SAVE
  JMP I CALL0  /JUMP TO IT
/
RET0,  /POP PC OFF OF RSTACK
  RPOP    /GET RETURN ADDRESS
  DCA CALL0  /SAVE
  JMP I CALL0  /JUMP TO IT
/
PPUSH0,  0  /PUSH AC TO PSTACK
  DCA CALL0  /SAVE AC
  CMA    /DEC PSP
  TAD PSP
  DCA PSP
  TAD DP    /PSP-DP-1=0?
  CMA
  TAD PSP
  SZA CLA
  JMP PPUSH1  /NO, EVERYTHING'S HIP
  ERROR
  TEXT /PSTACK OVERFLOW/
PPUSH1,  TAD CALL0  /RESTORE AC
  DCA I PSP  /PUSH IT
  JMP I PPUSH0
/
PAGE
/
PPOP0,  0  /POP AC FROM PSTACK
  CLA
  TAD PSP    /GET PSP
  TAD C0200  /PSP=7600?
  SZA CLA
  JMP PPOP1  /NO
  ERROR
  TEXT /PSTACK UNDFL/
PPOP1,  TAD I PSP  /POP A VALUE
  ISZ PSP    /INC PSP
  JMP I PPOP0  /RETURN
/
RPOP0,  0  /POP AC FROM RETURN STACK (7600-7777)
  TAD SP    /GET SP
  SZA CLA
  JMP RPOP1  /STACK OK, GO POP
  ERROR    /UNDERFLOW, PRINT ERROR
  TEXT /RSTACK UNDFL/
RPOP1,  TAD I SP  /GET AC
  ISZ SP    /INC SP
  NOP    /THIS WILL SKIP ON THE LAST WORD
  JMP I RPOP0  /RETURN
/
PPC0,  0  /PPUSH CONSTANT IN LOCN AFTER "PPUSHC"
  CLA
  TAD I PPC0  /GET CONSTANT
  PPUSH    /PPUSH IT
  ISZ PPC0  /INC PAST ARG
  JMP I PPC0  /RETURN
/
RUNIM0,  0  /RUN IMMEDIATE CODE
  TAD INWORD  /COMPILING A : DEFN?
  SZA CLA
  JMP IMM1  /YES, DON'T WORRY ABOUT NESTING
  TAD NLEVEL  /NLEVEL=NSP?
  CIA
  TAD NSP
  SNA CLA
  JMP IMM1  /YES, NO PROBLEM
  ERROR    /NO, GACK
  TEXT /UNCLOSED STRUC/
IMM1,  DCA CARETF  /NO "^" ON RUN-TIME ERRORS
  TAD CRET  /"RET" AT END OF IMM CODE
  DCA I IMMDP
  CALL    /CALL THE CODE
  ICODE
  TAD CICODE  /PT AT ICODE
  DCA IMMDP  /RESET IMMDP
  CMA    /^ ON ERRORS
  DCA CARETF
  JMP I RUNIM0  /RETURN
CRET,  RET
CICODE,  ICODE
/
NPUSH0,  0  /PUSH AC, @PC TO NESTING STACK
  DCA RPOP0  /SAVE AC
  TAD NSP    /GET NSTACK PTR
  TAD NPUSH2  /STACK FULL?
  SZA CLA
  JMP NPUSH1  /NO
  ERROR    /YES, ERROR
  TEXT /TOO MUCH NESTING/
NPUSH1,  TAD NSP    /GET OFFSET
  TAD CNSTAK  /ADD BASE
  DCA PPC0  /SAVE PTR
  TAD RPOP0  /GET ADDRESS BACK
  DCA I PPC0  /PUSH IT
  ISZ PPC0  /INC PTR
  ISZ NSP    /INC OFFSET
  TAD I NPUSH0  /GET KEYWORD TOKEN
  DCA I PPC0  /PUSH IT
  ISZ NSP    /INC OFFSET (NOT PTR)
  ISZ NPUSH0  /SKIP OVER ARG
  JMP I NPUSH0  /RETURN
NPUSH2,  -40  /STACK BIG ENOUGH FOR 16 LEVELS OF NESTING
CNSTAK,  NSTACK  /PTR TO BASE OF NSTACK
/
PAGE
/
NPOP0,  0  /POP AC OFF OF NESTING STACK
/CHECK TO SEE IF TOKEN AGREES WITH ONE AFTER CALL (NEGATIVE)
  CLA    /JUST TO MAKE SURE
  TAD NSP    /GET NSTACK PTR
  SZA    /SKIP IF EMPTY
  JMP NPOP1  /OTHERWISE START THE POP
  ERROR    /NO MATCHING NPUSH
  TEXT /STRUC ERR/
NPOP1,  TAD NSTAK1  /ADD BASE TO OFFSET
  DCA TEMP5  /SAVE THIS PTR
  TAD I TEMP5  /GET TOKEN
  TAD I NPOP0  /GET -TOKEN TO MATCH
  SNA CLA    /DO THEY MATCH?
  JMP NPOP2  /YES
  ERROR    /NO
  TEXT /NEST ERR/
NPOP2,  STA CLL RAL  /-2
  TAD NSP    /DEC NSP BY 2
  DCA NSP
  STA    /DEC PTR BY 1
  TAD TEMP5
  DCA TEMP5
  TAD I TEMP5  /GET ADDRESS
  ISZ NPOP0  /SKIP OVER TOKEN
  JMP I NPOP0  /RETURN
NSTAK1,  NSTACK-1
/
CURRD0,  0  /RETURN DP FOR CURRENT BUFFER
  CLA    /JUST MAKING SURE
  TAD INWORD  /IN A COLON DEFINITION?
  SZA CLA
  JMP .+3    /YES
  TAD IMMDP  /NO
  JMP I CURRD0  /RETURN
  TAD DP    /GET DICTIONARY POINTER
  JMP I CURRD0  /RETURN
/
/DATA AREAS
NSTACK=  .  /NESTING STACK
*.+40    /ALLOW 16. LEVELS OF NESTING
WORD=  .  /BUFFER FOR WORD
*.+40    /ALLOW 32. CHARS BEFORE HITTING LINE
LINE=  .  /BUFFER FOR INPUT LINE
*.+120    /ALLOW 80 CHARS
ICODE=  .  /BUFFER FOR IMMEDIATE MODE CODE
*.+200    /ALLOW A LOT OF THAT
DICT=  .  /START OF PREDEFINED DICTIONARY
/
  0100  /!
  PAREN
  TSUBR
/( VAL ADDR -- ) POKES ADDR TO VAL
  PPOP    /GET ADDRESS
  DCA TEMP1  /SAVE
  PPOP    /GET VALUE
  DCA I TEMP1  /POKE
  RET    /RETURN
/
PAREN,  1000  /(
  MULT
  TSTRU
/( -- TEXT ')') IGNORES TEXT TO NEXT ")"
  CLA
PAREN1,  TAD I LINPTR  /LOOK FOR ")"
  ISZ LINPTR  /PT AT NEXT CHAR
  SNA    /END OF LINE?
  JMP PAREN2  /YES, GO READ ANOTHER ONE (BIG COMMENT)
  TAD PAREN3  /")" ?
  SZA CLA
  JMP PAREN1  /NO, LOOP
  RTS    /YES, RETURN
PAREN2,  TAD CLINE  /PT AT LINE BUFF
  DCA TEMP1  /SAVE PTR FOR INPUT
  JMS I PAREN4  /CALL INPUT
  TAD CLINE  /PT AT LINE, AGAIN
  DCA LINPTR  /SET LINPTR TO POINT THERE
  JMP PAREN1  /SEARCH LINE FOR ")"
PAREN3,  -")  /SEARCH CHARACTER
PAREN4,  INPUT
/
MULT,  1200  /*
  PLUS
  TSUBR
  PPOP    /GET FIRST VALUE
  DCA TEMP1  /SAVE IT
  PPOP    /GET SECOND VALUE
  DCA TEMP2  /SAVE IT
  JMS MULT0  /PERFORM THE MULTIPLY
  TAD TEMP4  /GET THE PRODUCT
  PPUSH    /RETURN IT
  RET
/
MULT0,  0  /MULTIPLY TEMP1 BY TEMP2, RESULT IN TEMP4
  TAD M0014  /-12.
  DCA TEMP3  /BIT COUNTER
  DCA TEMP4  /ACCUMULATOR
MULT1,  TAD TEMP1  /GET MULTIPLIER
  RAR    /AC11 INTO LINK
  DCA TEMP1  /SAVE RESULT
  SNL    /SKIP IF 1
  JMP MULT2  /0, DON'T ADD
  TAD TEMP4  /GET ACCUMULATOR
  TAD TEMP2  /ADD MULTIPLICAND
  DCA TEMP4  /SAVE SUM
MULT2,  TAD TEMP2  /ROTATE MULTIPLICAND LEFT ONE BIT
  CLL RAL
  DCA TEMP2
  ISZ TEMP3  /DONE ALL 12. BITS?
  JMP MULT1  /NO, LOOP
  JMP I MULT0  /YES, RETURN (RESULT IN TEMP4)
M0014,  -14  /-(NUMBER OF BITS IN A WORD)
/
PLUS,  1300  /+
  COMMA
  TSUBR
( VAL1 VAL2 -- VAL1+VAL2) RETURNS SUM OF TOP TWO VALUES
  PPOP    /GET FIRST VALUE
  DCA TEMP1  /SAVE IT
  PPOP    /GET SECOND VALUE
  TAD TEMP1  /ADD FIRST VALUE
  PPUSH    /PUSH SUM
  RET
/
COMMA,  1400  /,
  MINUS
  TSUBR
( VALUE -- ) PUTS VALUE INTO DICTIONARY AND ADVANCES DP
  PPOP    /GET VALUE
  DCTVAL    /POKE INTO DICTIONARY
  RET
/
MINUS,  1500  /-
  DOT
  TSUBR
( VAL1 VAL2 -- VAL1-VAL2) RETURNS DIFFERENCE BETWIXT TOP TWO VALUES
  PPOP    /GET VAL1
  DCA TEMP1  /SAVE
  PPOP    /GET VAL2
  CIA    /NEGATE
  TAD TEMP1  /ADD VAL1
  PPUSH    /PUSH RESULT
  RET
/
DOT,  1600  /.
  DOTQ
  TSUBR
( VAL -- ) PRINTS VALUE ON TOP OF STACK, SIGNED
  PPOP    /GET VALUE
  JMS .+2    /PRINT THE VALUE
  RET    /RETURN
/
PRNUM0,  0  /PRINT SPACE, AC (SIGNED)
  SMA    /NEGATIVE?
  JMP PRNUM1  /NO
  CIA    /MAKE POSITIVE
  DCA TEMP1  /SAVE
  TYPE    /PRINT " -"
  " ;"-;0
  JMP PRNUM2  /GO PRINT THE #
PRNUM1,  DCA TEMP1  /SAVE NUMBER
  TYPE    /PRINT " "
  " ;0
PRNUM2,  TAD TEMP1  /GET NUMBER BACK
  JMS I PRNUM3  /PRINT IT
  RET    /AND RETURN
PRNUM3,  UPRNUM  /ROUTINE TO PRINT A #, UNSIGNED
/
*.  /TO AVOID "PE" ERRORS (PAL-D BUG)
DOTQ,  1602  /."
  0000
  DIVD
  TSTRU    /SPECIAL CASE COMPILATION
  PUTCON    /COMPILE "DOTQUO"
  DOTQUO
  JMS ASCIZ0  /COMPILE IN-LINE .ASCIZ CONSTANT
  RTS
/
ASCIZ0,  0  /COMPILE IN-LINE STRING TERMINATED WITH "
  TAD I LINPTR  /END OF LINE HERE?
  SNA CLA    /NO
  JMP ASCIZE  /YES, ERROR (UNTERMINATED)
ASCIZ1,  ISZ LINPTR  /PT AT NEXT CHAR
  TAD I LINPTR  /GET A CHAR (LOWER CASE OK)
  SNA    /SHOULDN'T BE END OF LINE
  JMP ASCIZE  /ERROR IF SO
  TAD ASCIZ3  /END OF STRING?
  SNA CLA
  JMP ASCIZ2  /YES, <NUL> AT END AND RETURN
  TAD I LINPTR  /NO, RESTORE CHAR
  PUTVAL    /PUT IN DICTIONARY
  JMP ASCIZ1  /LOOP
ASCIZ2,  ISZ LINPTR  /SKIP OVER "
  PUTVAL    /COMPILE A <NUL>
  RTS    /AND RETURN
ASCIZ3,  -242  /QUOTE
ASCIZE,  ERROR  /ERROR IF END OF LINE ENCOUNTERED
  TEXT /NO CLOSING "/
/
DOTQU0,  0  /RUN-TIME ROUTINE TO PRINT .ASCIZ STRING FOLLOWING CALL
  CLA    /JUST TO MAKE SURE
DOTQU1,  TAD I DOTQU0  /GET A CHAR
  ISZ DOTQU0  /PT AT NEXT ONE
  SNA    /DONE?
  JMP I DOTQU0  /YES, RETURN
  PRINT    /NO, PRINT THE CHAR
  JMP DOTQU1  /LOOP UNTIL 0
/
DIVD,  1700  /"/"
/ADD THIS LATER
USRDCT=  .  /USER-DEFINED WORDS START HERE
$ THAT'S ALL, FOLKS!

_________________
iLavr


17 May 2020 22:07
Profile
Doomed
User avatar

Joined: 05 Nov 2007 05:08
Posts: 487
Location: Украина
Reply with quote
тем временем у меня в подсознании вырисовался механизм LEAVE, но не просто описать.
в двух словах: DO - LEAVE - ...- LEAVE - LOOP должны формировать цепочку с переходами через друг друга в оба направления.


18 May 2020 00:52
Profile WWW
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
shoorick wrote:
тем временем у меня в подсознании вырисовался механизм LEAVE, но не просто описать.
в двух словах: DO - LEAVE - ...- LEAVE - LOOP должны формировать цепочку с переходами через друг друга в оба направления.

Всё бы хорошо, но если LEAVE стоит внутри IF (или даже вложенных) то при компиляции невозможно найти в стеке адрес неразрешённой ссылки. А всё потому, что форт Шихова не кладёт в стек тип управляющей конструкции (IF, DO или что-то ещё). Другие форты это делают.

Lavr wrote:
поэтому хотелось сделать LEAVE средствами самогО Форта

Можно отказаться от того, что по LEAVE цикл завершается немедленно. Обычно LEAVE стоит внутри условного оператора и можно оформить цикл следующим образом:
Code:
N1 N2 N3 +DO ... тело цикла ... условие выхода IF LEAVE ELSE ... продолжение тела цикла ... THEN REPEAT


В таких условиях реализация LEAVE очень простая:
Code:
: LEAVE R> R> R> DROP DUP >R >R >R ;


Однако в форте Шихова нет R> и >R. Но их можно реализовать. Обычно эти слова не являются компилирующими, однако в режиме интерпретации от них толку мало. Поэтому с целью оптимизации можно сделать их компилирующими.
Code:
: >R CDC5 , ['] DROP , ; IMMEDIATE
: R> CD C, ['] DUP , C1 C, ; IMMEDIATE


Однако в форте Шихова нет [']. Это слово компилирует константу, соответствующую CFA следующего за ним слова.
Можно конечно заменить ['] DROP на число (адрес CFA DROP), но это не комильфо.

Поэтому это слово тоже можно реализовать:
Code:
: ['] [ ' DUP DUP CD C, , 1 C, , ] CD C, , 1 C, ' , ; IMMEDIATE


И пара слов про IMMEDIATE. Шихов почему-то в своём примере реализовал его нестандартно, оно требует указать слово, которое объявляется исполнимым немедленно. В других версиях форта подразумевается последнее созданное слово. Т.е. можно сделать так:
Code:
: IMMEDIATE 1046 @ 2 + BEGIN DUP C@ 80 < IF 1 + REPEAT DUP C@ 40 OR SWAP C! ;


Итого имеем такой пример:
Code:
HEX
: IMMEDIATE 1046 @ 2 + BEGIN DUP C@ 80 < IF 1 + REPEAT DUP C@ 40 OR SWAP C! ;
: ['] [ ' DUP DUP CD C, , 1 C, , ] CD C, , 1 C, ' , ; IMMEDIATE
: >R CDC5 , ['] DROP , ; IMMEDIATE
: R> CD C, ['] DUP , C1 C, ; IMMEDIATE
: LEAVE R> R> R> DROP DUP >R >R >R ;
: TEST 5 1 1 +DO 31 EMIT I 3 = IF LEAVE ELSE 32 EMIT THEN REPEAT ;

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


Last edited by b2m on 18 May 2020 05:13, edited 1 time in total.



18 May 2020 05:01
Profile WWW
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Это были примеры полезных слов, но гораздо проще реализовать LEAVE как компилирующее слово:
Code:
: LEAVE F1D1 , D5D5 , ; IMMEDIATE

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


18 May 2020 05:05
Profile WWW
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Всё-таки добил я LEAVE до нужного состояния:
Code:
HEX
: IMMEDIATE 1046 @ 2 + BEGIN DUP C@ 80 < IF 1 + REPEAT DUP C@ 40 OR SWAP C! ;
: SP@ DUP [ 4D44 , ] ;
: ?DOPTR @ DUP 1 + @ 0DD8 = SWAP C@ CD = AND ;
: LEAVE F1D1 , D5D5 , SP@ BEGIN DUP 1080 < IF DUP ?DOPTR IF @ C3 C, , 1080 ELSE 2 + THEN REPEAT DROP ; IMMEDIATE
: TEST 5 1 1 +DO 31 EMIT I 3 = IF LEAVE THEN 32 EMIT REPEAT ;

Но это только для данной версии форта Шихова, в которой адрес одной из п/п 0DD8, а дно стека 1080.

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


18 May 2020 06:37
Profile WWW
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Кстати, если хочется иметь CONTINUE, то можно и так:
Code:
HEX
: IMMEDIATE 1046 @ 2 + BEGIN DUP C@ 80 < IF 1 + REPEAT DUP C@ 40 OR SWAP C! ;
: [COMPILE] CD C, ' , ; IMMEDIATE
: SP@ DUP [ 4D44 , ] ;
: ?DOPTR @ DUP 1 + @ 0DD8 = SWAP C@ CD = AND ;
: CONTINUE SP@ BEGIN DUP 1080 < IF DUP ?DOPTR IF @ C3 C, , 1080 ELSE 2 + THEN REPEAT DROP ; IMMEDIATE
: LEAVE F1D1 , D5D5 , [COMPILE] CONTINUE ; IMMEDIATE
: TEST 7 1 1 +DO I 30 + EMIT I 3 = IF CONTINUE THEN I 5 = IF LEAVE THEN 2C EMIT REPEAT ;

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


18 May 2020 10:27
Profile WWW
Supreme God
User avatar

Joined: 21 Oct 2009 08:08
Posts: 7777
Location: Россия
Reply with quote
Lavr wrote:
И я тут разыскал исходник Форта для PDP-8 исторических времён, не новодел:

Почитал я исходник этот внимательно - похоже на правду, хотя и не закончено по словам автора:
forth.pal
Partial FORTH system. I got a bit carried away with the
TTY input editing and focused on that instead of finishing
the dictionary, typical... But the basic pieces did work.
I later converted this program to run stand-alone and build
using the PALX.SAV cross-assembler I wrote for RT-11, since
at that point I had the bare 8/E CPU box in my dorm room,
attached to a PDT-11/150 through a serial line.

Интересно было, как реализуют стековый язык на принципиально бесстековой машине...

Но на активные поиски версии Forth для PDP-8 меня сподвинул несколько другой факт.
Серьёзная и известная леди из FORTH Inc. утверждала, что версия FORTH для PDP-8 существовала:
FORTH, Inc. experimented briefly with <16-bit Forths in the 70's. We had
a 12-bit PDP-8 system that was used in a couple of applications, and
briefly flirted with an 8-bit version when the first microprocessors
came out. But it was really not usable, and I think everyone else pretty
much came to the same conclusion.
...
Cheers,
Elizabeth

--
==================================================
Elizabeth D. Rather (US & Canada) 800-55-FORTH
FORTH Inc. +1 310.999.6784
5959 West Century Blvd. Suite 700
Los Angeles, CA 90045
http://www.forth.com

"Forth-based products and Services for real-time
applications since 1973."
==================================================

Но следов этой версии Forth-а мне нигде разыскать не удалось... :-?

Впрочем, как мне кажется, для удовлетворения любопытства имеющегося кода достаточно.
Хотя запустить Forth на эмуляторе PDP-8 хотелось, конечно же... :-?

_________________
iLavr


19 May 2020 08:58
Profile
Supreme God
User avatar

Joined: 21 Oct 2009 08:08
Posts: 7777
Location: Россия
Reply with quote
Lavr wrote:
Lavr wrote:
И я тут разыскал исходник Форта для PDP-8 исторических времён, не новодел:
Почитал я исходник этот внимательно - похоже на правду, хотя и не закончено по словам автора:
...
Интересно было, как реализуют стековый язык на принципиально бесстековой машине...
Тяжко этот исходник собирается... Оказалось, написан он под PAL-D, и кроссассемблеры,
ориентированные на PAL-8 некоторые слова в упор не понимают. :-?
Ниже список таких слов:
 OTHER RESIDENT IOTS
Code:
   /COMBINED RESIDENT IOTS
   UUOTBL, 6040 /TELEPRINTER
   6660 /LPT
   6030 /KEYBOARD
   6010 /READER
   6020 /PUNCH
   6500 /RESERVED FOR FUTURE USE
   0
   
   /UNCOMBINED RESIDENT IOTS
   
   6603 /RFILE
   6605 /WFILE
   6200 /CKS - CHECK STATUS
   6405 /CLS - CLEAR STATUS
   6400 /KSB - SET KEYBOARD BREAK
   6401 /SBC - SELECTIVE BUFFER CLEAR
   6402 /DUP - DUPLEX TELETYPE CONSOLE
   6403 /UND - UNDUPLEX TTY
   6411 /URT - USER RUN TIME
   6412 /TOD - TIME OF DAY
   6413 /RCR - RETURN CLOCK RATE
   6414 /DATE
   6415 /SYN - QUANTUM SYNCHRONIZATION
   6416 /STM - SET TIMER
   6417 /SRA - SET RESTART ADDRESS
   6617 /ACT - RETURN ACCOUNT NUMBER
   6420 /TSS - SKIP ON TSS/8
   6421 /USE - USER
   6422 /CON - USER CONSOLE
   6423 /PEEK - LOOK IN MONITOR CORE
   6430 /SSW - SET SWITCH REGISTER
   6431 /SEA - SET ERROR ADDRESS
   6614 /SIZE
   6004 /GTF - GET FLAGS ( LINK AND GT ONLY )
   6005 /RTF - RESTORE FLAGS (LINK AND GT ONLY)
   6006 /SGT - SKIP ON EAE GT FLAG
   6764 /DTXA - DECTAPE READ OR WRITE
   6771 /DTSF - DECTAPE SKIP
   6772 /RDS - READ DEVICE STATUS REGISTER (DT, RK, & CDR)
   6773 /DTSF RDS - MICROCODED
   6743 /DLAG - RK05 READ OR WRITE
   6632 /RCRA - READ CARD ALPHA
   6634 /RCRB - READ CARD BINARY
   6636 /RCRC - READ CARD COMPRESSED
   6615 /LOGOUT - MUST BE LAST IN GROUP, SEE ULOGO FOR DETAILS
   0
   
   /NON-RESIDENT IOTS
   
   
   6440 /ASD - ASSIGN DEVICE
   6442 /REL - RELEASE DEVICE
   
   6601 /OPEN - OPEN FILE
   6602 /CLOS - CLOSE FILE
   6600 /REN - RENAME FILE
   6604 /PROT - PROTECT FILE
   
   6610 /CRF - CREATE FILE
   6611 /EXT - EXTEND FILE
   6612 /RED - REDUCE FILE
   6406 /SEGS - RETURN NUMBER OF FREE DISK SEGMENTS
   0
   
   /LONG NON-RESIDENT IOTS
   
   6613 /FINF
   6616 /WHO
   0

Другой неприятный момент в том, что если что-то собиралось под PAL-D, то и работало оно
скорее всего на PDP-8/I под OS TSS/8.
А для неё требования к системе весьма нехилые: не менее 12288 слов памяти, из которых первые
8192 слов предназначались для размещения программ монитора операционной системы, а оставшиеся
4096 слов разделялись между пользователями системы.
Это далеко не всякий эмулятор сумеет...
По тексту также включены некоторые фрагменты для подавления ошибок PAL-D...
Но... будем посмотреть... :wink:

_________________
iLavr


22 May 2020 13:13
Profile
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Я собирал вот этим кросс-ассемблером: https://github.com/lisper/cpus-pdp8/tre ... tils/macro
Действительно, он не знает слова из приведённого выше списка, он ставит вместо них нули, что вобщем-то не страшно. Хотя я заменил эти команды на NOP.
Ну и чтобы запустить этот форт, традиционно допилил свой эмулятор:
Attachment:
forth-8.png
forth-8.png [ 30.46 KiB | Viewed 5538 times ]

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


22 May 2020 13:40
Profile WWW
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Странно, что вычитает он в другом порядке. Но этот форт вообще недоделан. Как видно из исходника, последнее слово, которое начал писать Джон - это деление. Но процедуру деления он не сделал. А эта процедура нужна, чтобы сделать вывод числа на экран. Слово "точка" есть, но ссылается на неопределённую процедуру UPRNUM. Да и вывод текстовой строки тоже пришлось допиливать - DOTQUO тоже не определено, хотя и можно добавить его на нулевую страницу (не путать О и ноль):
Code:
DOTQUO= JMS I .
        DOTQU0

Но лично я использовал вместо этого TYPE, процедура полностью аналогична, разве что не чистит AC в начале. Я вот взял и просто добавил CLA в начало TYPE.

Слово "двоеточие" для создания других слов он тоже не сделал. Хотя некоторые нужные для него процедуры уже есть: MAKEW0, неизвестно только, есть ли в ней ошибки.

--------

А вот что удивило, так это то, что вводимый с клавиатуры текст (в терминах других фортов - в режиме интерпретации) тоже компилируется и выполняется перед вводом следующей строки. То есть тут как-бы нет режима интерпретации. Но есть переключатель, куда компилировать - в словарь, или во временный буфер, который и исполняется по вводу строки.

Причём, как компилировать слово - определяет само слово. После того, как вводимое слово найдено в словаре, запускается код, адрес которого указан после имени. Получается путаница - то-ли это интерпретация, то-ли компиляция. Можно сказать, это интерпретация, результат которой - скомпилированный код.

Что касается скомпилированного кода - то это подпрограммный шитый код. Тут ничего необычного. Разве что тот факт, что в PDP-8 нет аппаратного стека, все стеки реализованы программно.

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


22 May 2020 14:13
Profile WWW
Supreme God
User avatar

Joined: 21 Oct 2009 08:08
Posts: 7777
Location: Россия
Reply with quote
b2m wrote:
... тот факт, что в PDP-8 нет аппаратного стека, все стеки реализованы программно.
Собственно, именно это и интересно! :kruto:

А там где есть и аппаратный стек, и развитая косвенная адресация (как в z80) - там удивляться
особо нечему...
Code:
; Jupiter ACE 'LEAVE'"
L1318:  POP     BC                      ; pop return address to BC.
        POP     HL                      ; pop the loop counter.
        POP     HL                      ; now the limit.
        PUSH    HL                      ; push unaltered limit.
        PUSH    HL                      ; push counter - now limit.
        PUSH    BC                      ; restore return address.

        JP      (IY)                    ; to 'next'.

А что у тебя скомпилировалось по адресам, выделенным красным, тоже нули?
Quote:
IF= JMS I .
WHILE= JMS I .
UNTIL= JMS I .
JUMPZ /PPOP, JUMP TO @PC IF ZERO
DO= JMS I .
DO0 /COPY TOP TWO ARGS ON PSTACK TO RSTACK
LOOP= JMS I .
LOOP0 /INC @RSP, LOOP IF NOT EQUAL TO @RSP+1, ELSE CLEAR RSTACK

_________________
iLavr


22 May 2020 15:54
Profile
Devil

Joined: 26 May 2003 06:57
Posts: 859
Reply with quote
Lavr wrote:
А что у тебя скомпилировалось по адресам, выделенным красным, тоже нули?

Да, но эти слова всё равно не реализованы и не используются.
 forth.err
Code:
forth.pal(84:9)    : error:  undefined symbol "JUMPZ" at Loc = 00050
forth.pal(86:9)    : error:  undefined symbol "DO0" at Loc = 00051
forth.pal(88:9)    : error:  undefined symbol "LOOP0" at Loc = 00052
forth.pal(120:9)   : error:  undefined symbol "SRA" at Loc = 00100
forth.pal(121:9)   : error:  undefined symbol "UND" at Loc = 00101
forth.pal(123:9)   : error:  undefined symbol "KSB" at Loc = 00103
forth.pal(141:9)   : error:  undefined symbol "CLOS" at Loc = 00152

      7 detected errors

 forth.lst
Code:
   81       4450  IF=     JMS I .
   82       4450  WHILE=  JMS I .
   83       4450  UNTIL=  JMS I .
   84 00050 0000          JUMPZ   /PPOP, JUMP TO @PC IF ZERO
UD undefined              ^
   85       4451  DO=     JMS I .
   86 00051 0000          DO0     /COPY TOP TWO ARGS ON PSTACK TO RSTACK
UD undefined              ^
   87       4452  LOOP=   JMS I .
   88 00052 0000          LOOP0   /INC @RSP, LOOP IF NOT EQUAL TO @RSP+1, ELSE CLEAR RSTACK
UD undefined              ^
   89             /

_________________
Страничка эмулятора наших компьютеров
http://bashkiria-2m.narod.ru/


23 May 2020 04:54
Profile WWW
Display posts from previous:  Sort by  
Reply to topic   [ 85 posts ]  Go to page Previous  1, 2, 3, 4, 5, 6  Next

Who is online

Users browsing this forum: No registered users and 21 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot post attachments in this forum

Search for:
Jump to:  
Powered by phpBB® Forum Software © phpBB Group
Designed by ST Software.