forth5mx_procs.opp

Descripción del contenido de la página

Uno de los ficheros fuentes principales de Forth 5mx, un Forth para la computadora Psion 5mx, escrito en OPL+.

Etiquetas:

Este fichero contiene procedimientos de uso general, o bien extraídos de la definición de palabras en Forth para ser reutilizados.

Código fuente

// forth5mx_procs.opp

// Copyright (C) 2004-2011,2015 Marcos Cruz (http://programandala.net)

// This file is part of Forth 5mx.

// Forth 5mx 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
// of the License, or (at your option) any later version.

// This program is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.

// You should have received a copy of the GNU General Public License
// along with this program. If not, see <http://gnu.org/licenses>.

/*

Procs

*/

// -------------------------------------------------------
// Some Forth words factored to procedures
// -------------------------------------------------------

proc dump:(a&,u&)

    local address&,count&
    local temp&,i&,char%

    address& = a&
    count& = u&
    while count&>0
        temp& = address&
        i& = 8
        print right$("0000000"+hex$(temp&)+"  ",8),
        while i&
            print right$("0"+hex$(peekb(temp&)),2),
            i&--
            temp&++
        endwh
        temp& = address&
        i& = 8
        while i&
            char% = peekb(temp&)
            if (char% < KKeySpace%)
                char% = %.
            endif
            print chr$(char%);
            i&--
            temp&++
        endwh
        print
        address& = address& + 8
        count& = count& - 8
    endwh

endp

// -------------------------------------------------------
// Low level procedures to build words
// -------------------------------------------------------

proc primitive&:(_name$,_control_bits%)

    header&:(_name$,_control_bits%)
    _COMMA?(last_nt&) // vector to OPL label

    return last_nt&

endp

proc header&:(_name$,_control_bits%)

    // Create a word header in the dictionary.

    _CALCULATE_HASH_LOCALS

    #ifdef _WARNING // does the warning feature must be compiled?
        _FIND_LOCALS  // locals needed by forth5mx_inc_find.opp
        if warning&
            nametofind$=_name$
            // input:nametofind$
            #include "forth5mx_inc_find.opp"
            // output: nt& = nt or 0
            if nt&
                print "Warning:",_name$,"isn't unique."
            endif
        endif
    #endif

#if 0 // obsolete
    last_nt& = last_nt&+1
    name&(last_nt&)=_NAME_ADDRESS
    poke$ name&(last_nt&), lower$(left$(_name$,KMaxHeaderSize%))
    dp& = _ALIGNED?(dp&)
    _COMMA?(last_nt&)
    pokel _XT_ADDRESS?(last_nt&), dp&
    pokeb _CONTROL_BITS_ADRESS?(last_nt&), _control_bits%
#else
    last_nt& = last_nt&+1
    poke$ _NAME_ADDRESS?(last_nt&), lower$(left$(_name$,KMaxNameSize%))
    dp& = _ALIGNED?(dp&)
    _COMMA?(last_nt&)
    pokel _XT_ADDRESS?(last_nt&), dp&
    pokeb _CONTROL_BITS_ADDRESS?(last_nt&), _control_bits%
#endif

// maybe faster with the former poke$ value? b!!!
    word$=_NAME?(last_nt&)
    // input: word$
    _CALCULATE_HASH
    // output: hash%

    #ifdef _DEBUG1
        if word$="drop"
            print "DROP hash=";hash%
            get
        endif
    #endif

    thread&(thread_pointer%) = thread&(hash%)
    thread&(thread_pointer%+1) = last_nt&
    thread&(hash%) = thread_pointer%
    thread_pointer% = thread_pointer%+2

endp

// -------------------------------------------------------
// Procedures to manage strings
// -------------------------------------------------------

proc move:(string$,addr&)

    // Store string$ in addr&.

    // ?!!!
    // used only by ACCEPT and EXPECT
    // Could be used the macro _STORE_STRING instead

    local temp&, i&

    temp& = len(string$)
    i& = 0 // ?!!! needed?
    while i& < temp&
        pokeb addr&+i&,asc(mid$(string$,i&+1,1))
        i& = i&+1
    endwh

endp

// -------------------------------------------------------
// Procedures to manage numbers
// (unfinished, experimental)
// -------------------------------------------------------

proc signed_unsigned:(number)

    // Return the two's complement of a 32-bit number,
    // but only if the number is in the range in which
    // the integer can be signed or unsigned.

    local complement

    // 4294967296 = 2^32
    // 2147483648 = 2^31
    // 2147483647 = 2^31 - 1

    complement = number
    if number<0
        complement = 4294967296+number
    elseif number>2147483647
        complement = -4294967296+number
    endif
    return complement

endp

proc complement2:(number)

    // Return the two's complement of a 32-bit number.

    local complement

    // 4294967296 = 2^32
    // 2147483648 = 2^31
    // 2147483647 = 2^31 - 1

    // :!!! ?!!!

    complement = number
    if number<0
        complement = 4294967296+number
    elseif number>2147483647
        complement = -4294967296+number
    endif
    return complement

endp

proc unsigned:(signed&)

    // :!!!

    // Return the unsigned 32-bit integer correspondent to a signed 32-bit integer.

    // 4294967296 = 2^32

/*
    local result
print "unsigned 1: "; result
    result=4294967296
print "unsigned 2: "; result
    result=result*abs(signed&<0)
print "unsigned 3: "; result
    result=result+signed&
print "unsigned 4: "; result
    return result
*/
    return 4294967296*abs(signed&<0)+signed&

endp

proc signed&:(unsigned)

    // Return the signed 32-bit integer correspondent to an unsigned 32-bit integer.

    // 4294967296 = 2^32
    // 2147483648 = 2^31
    // 2147483647 = 2^31 - 1
    return -4294967296*abs(unsigned>2147483647)+unsigned

endp

// -------------------------------------------------------
// Procedures to manage numbers
// -------------------------------------------------------

proc numberq%:(number$)

    // Used in NUMBER? and INTERPRET

    local startchar%,testchar%,currentchar%,valid%

    testchar% = len(number$)
    startchar% = (asc(left$(number$,1)) <> %-) + 1

    do
        #ifdef _NOT_DEFINED

        // old code

        currentchar% = asc(mid$(number$,testchar%,1))
        currentchar% = currentchar%-(currentchar%>=%a and %a)-(currentchar%<=%9 and 26)-22
        valid% = (currentchar% < base&) and (currentchar% >= 0)

        #else

        currentchar% = asc(mid$(number$,testchar%,1))
        // print mid$(number$,testchar%,1), currentchar% // d!!!
        valid%=CharIsAlphaDigit%:(currentchar%)
        if valid%
            currentchar%=currentchar%-%0-(7 and (CharIsAlpha%:(currentchar%)))-(32 and (CharIsLower%:(currentchar%)))
            // print "alphadigit converted to ";currentchar% // d!!!
            valid%=(currentchar% < base&)
        endif

        #endif

        testchar%--

    until (testchar% = startchar%) or (not valid%)

    return valid%

endp

proc number&:(number$)

    // Used in NUMBER and INTERPRET

    local lastchar%,testchar%,currentchar%
    local number, number&

    testchar% = (asc(left$(number$,1)) <> %-) + 2
    lastchar% = len(number$)
    number = 0

    do
        currentchar% = asc(mid$(number$,testchar%,1))
        currentchar% = currentchar% - %0 - (currentchar%>96 and 32) - (currentchar%>64 and 7)
        number = number*base&+currentchar%
        testchar%++
    until (testchar% > lastchar%)

    if (asc(left$(number$,1)) = %-)
        number = 0-number
        if number<-2147483648
            // error :!!!
        endif
    else
        if number>2147483647
            number=signed&:(number)
        endif
    endif

    return number

endp

proc digit:

    // ?!!!

    local temp&

    temp& = mod&:(tos&,base&)
    tos& = tos&/base&
    if temp& > 41 // 41 = ascii )
        temp& = temp&+39 // 39 = ascii '
    endif
    hold: (temp&+48) // 48 = ascii 0

endp

proc hold:(char&)

    // ?!!!

    local temp&

    temp& = pad&
    pokel temp&,peekl(temp&)-1
    pokeb peekl(temp&),char&

endp

// -------------------------------------------------------
// Terminal input
// -------------------------------------------------------

proc press_key:

    print "-- Press a key to continue. --" // ?!!!
    get

endp

proc lineedit$:(line$,len&,dohotkey&)

    local editcmd%(13) // one more than needed; the last element must be zero
    local cmd%
    local line1$(KMaxStringLen%)
    local key%
    local cursor%
    local temp%
    local to%,from% // used in left and right movements
    local clipboard$(KMaxStringLen%)
    local current_history%

    current_history%=LastHistory%

    editcmd%(1) = KKeyDel%
    editcmd%(2) = KKeyLeftArrow%
    editcmd%(3) = KKeyRightArrow%
    editcmd%(4) = KKeyPageLeft%
    editcmd%(5) = KKeyPageRight%
    editcmd%(6) = KKeyEsc%
    editcmd%(7) = KKeySidebarMenu%+3 // zoom out
    editcmd%(8) = KKeySidebarMenu%+4 // zoom in
    editcmd%(9) = 12  // Ctrl L
    editcmd%(10) = KKeyUpArrow%
    editcmd%(11) = KKeyDownArrow%
    editcmd%(12) = 22 // Ctrl V

    line1$ = line$
    cursor% = len(line1$)+1
    print
    showline: (line1$,cursor%)
    key% = get
    if key%=5 // Ctrl E
        bye:
    endif
    while key% <> KKeyEnter%
        if key% >= KKeySpace& and  key% <= 255
            // printable char
            if len(line1$) < len&
                line1$ = left$(line1$,cursor%-1)+chr$(key%)+mid$(line1$,cursor%,KMaxStringLen%)
                cursor% = cursor%+1
                showline:(line1$,cursor%)
            else
                beep 2,800
            endif
        else
            // edit command
            cmd% = 0
            do
                cmd% += 1
            until editcmd%(cmd%)=0 or editcmd%(cmd%)=key%
            vector cmd%
                backspace
                cursorleft
                cursorright
                cursorhome
                cursorend
                eraseline
                zoomin
                zoomout
                clearscreen
                cursorup
                cursordown
                paste
            endv
/*
            if dohotkey&
                if xkeytable&
                    print
                    print "keytable has no function yet. key was ",key%
                    showline:(line1$,cursor%)
                endif
            endif
*/
            beep 2,800
            goto nextkey

paste::

            clipboard$=from_clipboard$:
            if len(clipboard$)<=(len&-len(line1$))
                line1$ = left$(line1$,cursor%-1)+clipboard$+mid$(line1$,cursor%,KMaxStringLen%)
                cursor% = cursor%+len(clipboard$)
                showline:(line1$,cursor%)
            else
                beep 2,800
            endif
            goto showline

clearscreen::
            cls
            goto showline

backspace::

            if kmod = KKmodShift%
                if cursor% <= len(line1$)
                    line1$ = deletechar$:(line1$,cursor%)
                endif
            elseif cursor% > 1
                cursor%--
                line1$ = deletechar$:(line1$,cursor%)
            endif
            goto showline

/* // :!!!
            cursor% = cursor%-(kmod<>KKmodShift%)*(cursor%>1)
            line1$ = left$(line1$,max(0,cursor%-1))+mid$(line1$,max(len(line1$),cursor%+1),KMaxStringLen%)
            goto showline
*/

cursorleft::
            if kmod = 0
                // move to the next left character
                cursor% = max(cursor%-1,1)
            else
                if kmod = KKmodControl%
                    // move to the next left word
                    temp%=0
                    to%=asc(mid$(line1$,cursor%,1))
                    from%=to%
                    while (cursor%>1) and not(from%<>KKeySpace% and to%=KKeySpace% and temp%>1)
                        from%=to%
                        cursor%--
                        temp%++
                        to%=asc(mid$(line1$,cursor%,1))
                    endwh
                    cursor%=cursor%+iabs(cursor%<>1)
                endif
            endif
            goto showline

cursorright::
            if kmod = 0
                // move to the next right character
                cursor% = min(cursor%+1,len(line1$)+1)
            else
                if kmod = KKmodControl%
                    // move to the next right word
                    to%=asc(mid$(line1$,cursor%,1))
                    from%=to%
                    while (cursor%<len(line1$)) and not(from%=KKeySpace% and to%<>KKeySpace%)
                        from%=to%
                        cursor%++
                        to%=asc(mid$(line1$,cursor%,1))
                    endwh
                endif
            endif
            goto showline

cursorup::

            if current_history%
                line1$=history$(current_history%)
                current_history%--
                if current_history%<1
                    current_history%=MaxLastHistory%
                endif
                goto cursorhome
            else
                beep 2,800
            endif

cursordown::

            if current_history%
                line1$=history$(current_history%)
                current_history%++
                if current_history%>MaxLastHistory%
                    current_history%=1
                endif
            else
                beep 2,800
            endif

cursorhome::
            cursor% = 1
            goto showline

cursorend::
            cursor% = len(line1$)+1
            goto showline

eraseline::
            showline:(rept$(" ",len(line1$)+1),0)
            line1$ = ""
            cursor% = 1
            goto showline

zoomin::
            temp% = 1
            goto changefont

zoomout::
            temp% = -1

changefont::
            temp% = max(min(font%+temp%,KFonts%),1)
            setfont:(temp%,fontattr%)
            hello:
            print "font",font%,"of",KFonts%;":",screeninfo%(4);"×";screeninfo%(3)
            _OK

showline::
// print "lh=";lasthistory%;" mlh=";maxlasthistory%;" ch=";current_history% // d!!!
            showline:(line1$,cursor%)

nextkey::

        endif
        key% = get

    endwh

//  showline:(line1$,not(cursor%)) // old!!!
    print chr$(KKeyEnter%);line1$;chr$(KKeySpace&)

    if len(line1$)
        // Add to the history
        LastHistory%++
        if LastHistory%>KMaxHistory%
            LastHistory%=1
        endif
        MaxLastHistory%++
        MaxLastHistory%=min(MaxLastHistory%,KMaxHistory%)
        history$(LastHistory%) = line1$
    endif

    return line1$

endp

proc deletechar$:(line$,cursor%)

    return left$(line$,cursor%-1)+mid$(line$,cursor%+1,KMaxStringLen%)

endp

proc showline:(line$,cursor%)

    local screen_width%
    local offset%
    local line_showed$(KMaxStringLen%)
    local cursor_showed%
    local temp%

    screeninfo screeninfo%()
    screen_width%=screeninfo%(KSInfoAScrW%)-1
    offset%=max(1,max(cursor%,1)-screen_width%+1)
    line_showed$=mid$(line$,offset%,screen_width%+(cursor%>len(line$)))+left$(" ",iabs(cursor%>len(line$)))
    cursor_showed%=max(cursor%,1)-offset%+1

// *!!!
// cls
// print "[";rept$("-",screen_width%-2);"]"
// print "len=";len(line$);" cursor=";cursor%;" width=";screen_width%;" len_sh=";len(line_showed$);" cursor_sh=";cursor_showed%

    gupdate off
    print chr$(KKeyEnter%);
    print left$(line_showed$,cursor_showed%-1);
    style KgStyleInverse%
    print mid$(line_showed$,max(1,cursor_showed%),iabs(cursor_showed%<=len(line_showed$))); // cursor
    style fontattr%
    print right$(line_showed$,max(0,len(line_showed$)-cursor_showed%));
    print left$(" ",iabs(len(line_showed$)<screen_width%));
    temp%= screen_width%-len(line_showed$)-1
    temp% = temp%*iabs(temp%>0)
    print rept$(" ",temp%);  // erase possible rests of history commands
    gupdate on

endp


// -------------------------------------------------------
// Screen
// -------------------------------------------------------

proc setfont:(fontsize%,desiredattr%)

    local font&,usedattr%

    font% = fontsize%
    fontattr% = desiredattr%
    usedattr% = desiredattr% and (not 1)
    if desiredattr% and 1
        usedattr% = usedattr% or boldattr%(fontsize%)
        font& = boldfont&(fontsize%)
    else
        usedattr% = usedattr% or thinattr%(fontsize%)
        font& = thinfont&(fontsize%)
    endif
    font font&,usedattr%
    screeninfo screeninfo%()

endp

proc hello:

    cls
    print "Forth 5mx (version ";_VERSION;")"
    print "A Forth for the Psion 5mx computer"
    print "Copyright (C) 2004-2010 Marcos Cruz (http://programandala.net)"
    print "This program comes with ABSOLUTELY NO WARRANTY. This is free software,"
    print "and you are welcome to redistribute it under certain conditions;"
    print "for details type LICENSE ."

endp

/*
// obsolete
proc mm$:(month_abbr$)

    local temp%
    temp% = loc("JanFebMarAprMayJunJulAugSepOctNovDec",month_abbr$)
    temp% = temp%/3+1
    return right$("0"+gen$(temp%,2),2)

endp

proc version$:(opp_date$)

    return "v."+right$(opp_date$,4)+mm$:(left$(opp_date$,3))+mid$(opp_date$,5,2)+" r."+gen$(KRelease%,1)

endp
*/

proc indicate:(string$)

    if string$ <> indicator$
        indicator$ = string$
        if len(indicator$)
            busy indicator$,KBusyBottomRight%
        else
            busy off
        endif
    endif

endp

// -------------------------------------------------------
// Error
// -------------------------------------------------------

proc report_error:(error$)

    /* This proc must be called with the macro _REPORT_ERROR,
    that inits the global variables needed here and in the debug proc.
    */

    local errorlocation%, key%

    print
    if sourceid&
        // loading from file
        print g_ib$
    endif
    errorlocation% = max(0,g_toin&-len(g_parsed_word$)-1)
    print rept$(" ",errorlocation%);rept$("^",len(g_parsed_word$))
    print "error:",upper$(g_parsed_word$)
    print error$
    if error_sound&
        // provisional :!!!
        // It should be controled from Forth
        beep 32,800
        // playsound:("z:\system\alarms\timbre",volume&)
    endif
    print "-- Press [D] to debug. Any other to continue. --"
    key%=get
    if key%=%D or key%=%d
        debug:(error$) // *!!!
    endif

endp

// -------------------------------------------------------
// Files
// -------------------------------------------------------

proc whole_path$:(given_path$)

    // Return whole path.

    local new_path$(KMaxStringLen%),drive$(2),i%

    new_path$=backslash$:(given_path$)

//  if mid$(new_path$,2,1)=":"
//      drive$=left$(new_path$,2)
//      new_path$=right$(new_path$,len(new_path$)-2)
// else
//      drive$=left$(path$,2)
//  endif

    if left$(new_path$,1)="\"
        new_path$=left$(path$,2)+new_path$
//  elseif left$(new_path$,1)="~\"
//      new_path$=home_path$+right$(new_path$,len(new_path$)-2)
//  elseif left$(new_path$,2)=".\"
//      new_path$=path$+right$(new_path$,len(new_path$)-2)
//  elseif left$(new_path$,3)="..\"
//      new_path$=parent_dir$:(path$)+right$(new_path$,len(new_path$)-3)
    elseif mid$(new_path$,2,1)<>":"

        new_path$=path$+new_path$
    endif

    // Take ".\" off:

    i%=loc(new_path$,"\.\")
    while i%
        new_path$=left$(new_path$,i%)+right$(new_path$,len(new_path$)-i%-2)
        i%=loc(new_path$,"\.\")
    endwh

    // Make "..\" efective:

    i%=loc(new_path$,"\..\")
    while i%
        new_path$=parent_dir$:(left$(new_path$,i%))+right$(new_path$,len(new_path$)-i%-3)
        i%=loc(new_path$,"\..\")
    endwh

    return new_path$

endp

proc backslash$:(given_path$)

    // Changes Unix slashes into DOS backslashes.

    local new_path$(KMaxStringLen%),addr&,i%

    new_path$=given_path$
    addr&=addr(new_path$)

    i%=peekb(addr&)
    while i%
        if peekb(addr&+i%)=%/
            pokeb(addr&+i%),KCharBackSlash%
        endif
        i%=i%-1
    endwh

    return new_path$

endp

proc parent_dir$:(given_dir$)

    // Return the parent of a given directory

    // :!!!

    local parent$(KMaxStringLen%),parent&,i%,c%

    parent$=backslash$:(given_dir$)
    parent&=addr(parent$)

    i%=peekb(parent&)

    do
        i%=i%-1
        c%=peekb(parent&+i%)
    until c%=KCharBackSlash% or c%=%: or i%=0

    pokeb parent&,i%

    return parent$

endp

proc only_path$:(path_and_file$)

    // Return only the path, without the file name.

    local path$(KMaxStringLen%), path&, i%

    path$ = path_and_file$
    path& = addr(path$)
    i% = peekb(path&)

    while i%
        if peekb(path&+i%)=KCharBackSlash%
            break
        endif
        i%=i%-1
    endwh

    pokeb path&,i%

    return path$

endp

proc OBSOLETE_close_file:(file_id&)

    if ioclose(file_id&)
        report_error:("error closing file")
    endif

endp

proc unlimited_ioread&:(fileid&,address&,bytes&)

    // Read up to bytes& bytes from a file with the handle fileid% as set by IOOPEN.
    // address& is the address of a buffer into which the data is read.
    // This proc does not have the 16 KiB limit of the original ioread().

    // 2007-10-19
    // 2008-05-11 Bug fixed

    local current_address&
    local bytes_left&
    local bytes_to_read%
    local ior%
    local ret&

    current_address& = address&
    bytes_left& = bytes&

    ior%=0 // :!!! not needed
    while bytes_left& and ior%>-1
        bytes_to_read% = min(16384,bytes_left&)
        ior%=ioread(fileid&,current_address&,bytes_to_read%)
// old code: //
//      if ior%<0
//          // ior% = error code
//          bytes_left&=0  // exit
//      else
        if ior%>0
            // ior% = bytes read
            current_address&+=ior%
            bytes_left&-=ior%
        endif
    endwh

    if ior%>=0 or ior%=-36
        // no error or "end of file"
        // :!!! this calculation is not real in case of error -36:
        ret&=bytes&-bytes_left&
    else
        // error
        ret&=ior%
    endif

    return ret&

endp

// -------------------------------------------------------
// Debug
// -------------------------------------------------------

/* unused
proc debug_packed$:(_addr&,_len&)

    // debug procedure *!!!

    // Print the string whose address and lenght are indicated.

    local string$(KMaxStringLen%), addr&, len&
    addr& = _addr&
    len& = _len&
    while len&
       string$ = string$+chr$(peekb(addr&))
       len& = len&-1
       addr& = addr&+1
    endwh
    print string$
    debug:("fin de debug_packed$")

endp
*/

proc pointed$:(pointer1&,pointer2&,_mark$)

    // pointer1& = 0 ... depth
    // pointer2& = 0 ... depth
    // _mark$ = character to return

    // Return a character if both pointers are the same. Otherwise return an empty string.

    local mark$(1)

    if pointer1&=pointer2&
        mark$=_mark$
    endif

    return mark$

endp

proc stack_element&:(n&)

    // n& = 0 ... data stack depth

    // Return an element from the data stack.

#ifdef _TOS
    return g_tos&*iabs(n&=0)+peekl(g_sp&+KCell&*(n&-1))*iabs(n&>0)
#else
    return peekl(g_sp&+KCell&*n&)
#endif

endp

proc rstack_element&:(n&)

    // n& = 0 ... return stack depth

    // Return an element from the return stack.

    return peekl(g_rp&+KCell&*n&)

endp

proc debug_type:(address&,len&)

    local a&,i&

    a& = address&
    i& = len&
    while i&
        print chr$(peekb(a&));
        a& = a&+1
        i& = i&-1
    endwh
    print
    print "Press any key to continue"
    get

endp


proc debug:(debug_point$)

    /* This proc must be called with the macro _DEBUG,
    that inits the global variables needed here.
    */

    local inwp&
    local depth&,rdepth&
    local stack_pointer&,rstack_pointer&
    local option%
    local title$(KMaxStringLen%)
    local a1&,u1&,i&

    if not debug&
        return 0
    endif
    beep 10,800

    inwp& = 0
    screeninfo screeninfo%()
    title$=" DEBUG POINT"+left$(": ",2*iabs(debug_point$<>""))+debug_point$+" "
    title$=rept$("*",(screeninfo%(3)-len(title$))/2)+title$+rept$("*",(screeninfo%(3)-len(title$))/2)

    do

        print :print title$

        print "ip=";g_ip&,
        if g_ip&
            print "(ip)=";peekl(g_ip&),
        endif
        print "wp=";g_wp&,
        if g_wp&
            print "(wp)=";peekl(g_wp&);" ( ";_NAME?(peekl(g_wp&));" )",
        endif
        print "dp=";g_dp&,
        print "latest=";g_last_nt&;" ( ";_NAME?(g_last_nt&);" )"

        // data stack

        print "Data stack: sp0=";g_sp0&,"sp=";g_sp&,"(";
        depth&=(g_sp0&-g_sp&)/KCell&
        if depth&
            print depth&;" element";left$("s",iabs(depth&>1));")"
            print "( S: ";
#ifdef _TOS
            while depth&>1
                print pointed$:(depth&-1,stack_pointer&,"<");peekl(g_sp&+KCell&*(depth&-2));pointed$:(depth&-1,stack_pointer&,">");" ";
                depth&--
            endwh
            print pointed$:(0,stack_pointer&,"<");g_tos&;pointed$:(0,stack_pointer&,">");" ";
#else
            while depth&
                print pointed$:(depth&-1,stack_pointer&,"<");peekl(g_sp&+KCell&*(depth&-1));pointed$:(depth&-1,stack_pointer&,">");" ";
                depth&--
            endwh
#endif
        else
            print "empty";
        endif
        print ")"

        // return stack

        print "Return stack: rp0=";g_rp0&,"rp=";g_rp&,"(";
        rdepth&=(g_rp0&-g_rp&)/KCell&
        if rdepth&
            print rdepth&;" element";left$("s",iabs(rdepth&>1));")"
            print "( R: ";
            while rdepth&
                print pointed$:(rdepth&-1,rstack_pointer&,"{");peekl(g_rp&+KCell&*(rdepth&-1));pointed$:(rdepth&-1,rstack_pointer&,"}");" ";
                rdepth&=rdepth&-1
            endwh
        else
            print "empty";
        endif
        print ")"

        print "source recursion=";g_source_recursion%;
        print " source-id=";g_sourceid&;
        print "ib_len&=";g_ib_len&;" >IN=";g_toin&
        print "ib$=«";left$(g_ib$,g_toin&);"[>IN]";right$(g_ib$,max(0,len(g_ib$)-g_toin&));"»"
        print "(ib_addr&)=«";
        if g_ib_len&
            i&=0
            while i&<g_ib_len&
                print chr$(peekb(g_ib_addr&+i&));
                i&++
            endwh
        endif
        print "»"

        print
        print "General commands: [a]bort [b]ye [l]eave debug-[o]ff"
        print "Data stack commands: [<>] [e]mit [f]etch [t]ype [d]ump"
        print "Return stack commands: [{}] [E]mit [F]etch [T]ype [D]ump"
        print rept$("*",screeninfo%(3)-1)

        option%=get
        if option%=%f
            // @
            print stack_element&:(stack_pointer&);" @ ";peekl(stack_element&:(stack_pointer&))
            print stack_element&:(stack_pointer&);" C@ ";peekb(stack_element&:(stack_pointer&))
            press_key:
        elseif option%=%F
            // @
            print rstack_element&:(rstack_pointer&);" @ ";peekl(rstack_element&:(rstack_pointer&))
            print rstack_element&:(rstack_pointer&);" C@ ";peekb(rstack_element&:(rstack_pointer&))
            press_key:
        elseif option%=%b
            stop
        elseif option%=%D
            // DUMP from the return stack
            dump:(rstack_element&:(rstack_pointer&),64)
            press_key:
        elseif option%=%d
            // DUMP from the data stack
            dump:(stack_element&:(stack_pointer&),64)
            press_key:
        elseif option%=%E
            // EMIT from the return stack
            print rstack_element&:(rstack_pointer&);" EMIT ";chr$(rstack_element&:(rstack_pointer&))
            press_key:
        elseif option%=%e
            // EMIT from the data stack
            print stack_element&:(stack_pointer&);" EMIT ";chr$(stack_element&:(stack_pointer&))
            press_key:
        elseif option%=%o
            debug&=KFalse&
        elseif option%=%T
            // TYPE from the return stack
            debug_type:(rstack_element&:(rstack_pointer&),rstack_element&:(rstack_pointer&-1))
        elseif option%=%t
            // TYPE from the data stack
            debug_type:(stack_element&:(stack_pointer&),stack_element&:(stack_pointer&-1))
        elseif option%=%>
            stack_pointer&=stack_pointer&-iabs(stack_pointer&>0)
        elseif option%=%<
            stack_pointer&=stack_pointer&+iabs(stack_pointer&<((g_sp0&-g_sp&)/KCell&-1))
        elseif option%=%}
            rstack_pointer&=rstack_pointer&-iabs(rstack_pointer&>0)
        elseif option%=%{
            rstack_pointer&=rstack_pointer&+iabs(rstack_pointer&<((g_rp0&-g_rp&)/KCell&-1))
        endif

    until option%=%l or option%=%a or option%=%o

    aborted% = (option%=%a)

endp

proc trace_message:(text$)

print text$;" - PRESS ANY KEY"
get

endp

// -------------------------------------------------------
// Clipboard
// -------------------------------------------------------

proc from_clipboard$:

    // Return the string in the clipboard.
    // Copied from the OPL_Knowledge_base

    local string$(255),len&

    len&=read_clipboard_buffer&:(addr(string$)+1,int(255))
    pokeb addr(string$),len&
    return string$

endp

proc read_clipboard_buffer&:(_Buf&,Bytes&)

    // Copied from the OPL_Knowledge_base

    local CbId%,cbLen&,Pos&,Offset&

    Offset&=16
    IOOPEN(CbId%,KClipboardFile$,512)
    IOSEEK(CbId%,1,Offset&)
    IOREAD(CbId%,ADDR(Pos&),4)
    IOREAD(CbId%,ADDR(cbLen&),4)
    cbLen&=MIN(cbLen&,Bytes&)
    IOREAD(CbId%,_Buf&,cbLen&)
    IOCLOSE(CbId%)

    return cbLen&

endp

// -------------------------------------------------------
// Command history
// -------------------------------------------------------

proc read_history:

    local fid%
    local line%
    local ioret%
    local address&

    ioret% = IOOPEN(fid%,HistoryFile$,KIoOpenModeOpen% OR KIoOpenFormatText%)
    if ioret%=0
        line%=1
        do
            address&=addr(history$(line%))
            ioret% = IOREAD(fid%,address&+1,KMaxStringLen%)
            if ioret%>0
                pokeb address&,ioret%
                // print line%,"==>",history$(line%) // d!!!
                line%++
            endif
            // print "ioret%=",ioret% : get // d!!!
        until line%>KMaxHistory% OR ioret%<0
        MaxLastHistory%=line%-1
        LastHistory%=line%-1
        IOCLOSE(fid%)
        // get // d!!!
    endif

endp

proc write_history:

    local fid%
    local line%
    local ioret%
    local address&

    line%=1
    ioret% = IOOPEN(fid%,HistoryFile$,KIoOpenModeReplace% OR KIoOpenFormatText%)
    if ioret%=0
        do
            if len(history$(line%))
                address&=addr(history$(line%))
                ioret% = IOWRITE(fid%,address&+1,peekb(address&))
            endif
            // print line%,"==>",history$(line%) // d!!!
            line%++
        until line%>MaxLastHistory% OR ioret%<0
        IOCLOSE(fid%)
    endif
    // get // d!!!
endp

proc bye:
    #ifdef _ASM
    MCUnloadExt&:(mc_handle&) // remove the machine code extension
    FREEALLOC mc_workspace&  // release the allocated memory
    #endif
    write_history:
    stop
endp