Programkoden från föreläsningen (för gforth):

0 warnings !

: struct
  0 ;

: field
  create over , + does> @ + ;

: end-struct
  constant ;

struct
  cell field line.next
  cell field line.length
  cell field line.buffer
end-struct line

variable 1st  \ initialised to 0 in gforth
variable cur
variable curno

: goto-1st ( - )
  1st @ cur ! 1 curno ! ;  

: cur-next ( - addr )
  cur @ line.next @ ;

: goto-next ( - )
  cur-next cur ! 1 curno +! ;

: new-line  ( - addr )
  line allocate throw
  0 over line.length !
  0 allocate throw over line.buffer ! ;

: insert-1st ( addr - )
  1st @ over line.next !
  1st ! goto-1st ;

: insert-next ( addr - )
  cur-next over line.next !
  cur @ line.next ! goto-next ;

: insert-line ( - )
  new-line
  cur @ if insert-next else insert-1st then ;

: resize-line ( addr - )
  dup line.buffer @ over line.length @ resize throw
  swap line.buffer ! ;

: append-char ( c - )
  cur @ line.length dup @ dup char+ rot ! cur @ resize-line
  cur @ line.buffer @ + c! ;

: delete-char ( - )
  -1 cur @ line.length +! ;

: goto-line ( n - )
  ?dup 0= 1st @ 0= or if 0 curno ! 0 cur ! exit then
  goto-1st
  begin
    dup curno @ <> cur @ line.next @ and
  while
    goto-next
  repeat drop ;

: file-length ( - n )
    0 1st begin @ ?dup while line.next swap 1+ swap repeat ;

: print-line ( addr n - )
  cr . dup line.buffer @ swap line.length @ type ;

: free-line ( addr - )
  dup line.buffer @ free throw free throw ;

: unlink-line ( addr - ) \ takes address of pointer to line to be unlinked
  dup @ line.next @ swap ! ;

: delete-lines ( n addr - ) \ takes address of pointer to first line to delete
  swap 0 ?do dup @ 0= if leave then
    dup @ over unlink-line free-line
  loop @ cur !
  cur @ 0= if
    1st @ 0= if 0 curno ! else file-length goto-line then
  then ;

: echo ( key - )
  dup #bs = if dup emit space then emit ;

: default ( ... n - n )
  depth 1 > if drop then ;

\ förklara vocabularies, VOCS, ORDER, DEFINITIONS, ONLY, ALSO, VOCABULARY

vocabulary editor-words
editor-words definitions

: i ( - )
  #cr begin
    dup #esc = if drop exit then
    dup #cr  = if drop insert-line cr ." >" else
    dup #bs  = if echo delete-char else
               dup echo append-char then then
  key again ;

: p ( n? - )
  5 default
  cur @ curno @
  rot 0 ?do over 0= if leave then
    2dup print-line
    1+ swap line.next @ swap
  loop 2drop ;

: g ( n? - )
  1 default goto-line ;

: l ( - )
  file-length . ." lines total" ;

: c ( - )
  1 p ;

: $ ( - n )
  file-length ;

: d ( n? - )
  1 default
  1st begin dup @ cur @ <> while @ line.next repeat
  delete-lines ;

: r ( - )
  parse-name r/o open-file ?dup if .error exit then { fd }
  #lf begin
    dup #lf = if drop insert-line else append-char then             
    fd key-file fd file-eof? until
  drop fd close-file drop 
  cur @ line.length @ 0= if d then ;

: w ( - )
  parse-name w/o create-file ?dup if .error exit then { fd }
  1st @ begin
    dup line.buffer @ over line.length @ fd write-line throw
  line.next @ dup while repeat
  drop fd close-file drop ;

: ? ( - )
  cr ."     r <name> read file      w <name> write file     l show file length"
  cr ." (1) g  goto line        (5) p  print lines      (1) d delete lines"
  cr ."     c  print current line   i  insert lines"
  cr ." Defaults in ( ). 0 g i to insert before first line. $ for last line."
  ;

:noname
  begin cr ." *" refill while interpret repeat
  bye ;
is 'quit

seal