From 04e68443040c7abad84d66477e98f93bed701760 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Mon, 4 Feb 2019 13:09:03 +0100 Subject: Initial import --- system/multiuser/1.7.5/src/nameset | 355 +++++++++++++++++++++++++++++++++++++ 1 file changed, 355 insertions(+) create mode 100644 system/multiuser/1.7.5/src/nameset (limited to 'system/multiuser/1.7.5/src/nameset') diff --git a/system/multiuser/1.7.5/src/nameset b/system/multiuser/1.7.5/src/nameset new file mode 100644 index 0000000..8ea4359 --- /dev/null +++ b/system/multiuser/1.7.5/src/nameset @@ -0,0 +1,355 @@ +(* ------------------- VERSION 3 17.03.86 ------------------- *) +PACKET name set DEFINES (* Autor: J.Liedtke *) + + ALL , + SOME , + LIKE , + + , + - , + / , + do , + FILLBY , + remainder , + + fetch , + save , + fetch all , + save all , + forget , + erase , + insert , + edit : + + +LET cr lf = ""13""10"" ; + +TEXT VAR name ; +DATASPACE VAR edit space ; + +THESAURUS VAR remaining thesaurus := empty thesaurus ; + + +THESAURUS OP + (THESAURUS CONST left, right) : + + THESAURUS VAR union := left ; + INT VAR index := 0 ; + get (right, name, index) ; + WHILE name <> "" REP + IF NOT (union CONTAINS name) + THEN insert (union, name) + FI ; + get (right, name, index) + PER ; + union . + +ENDOP + ; + +THESAURUS OP + (THESAURUS CONST left, TEXT CONST right) : + + THESAURUS VAR union := left ; + IF NOT (union CONTAINS right) + THEN insert (union, right) + FI ; + union . + +ENDOP + ; + +THESAURUS OP - (THESAURUS CONST left, right) : + + THESAURUS VAR difference := empty thesaurus ; + INT VAR index := 0 ; + get (left, name, index) ; + WHILE name <> "" REP + IF NOT (right CONTAINS name) + THEN insert (difference, name) + FI ; + get (left, name, index) + PER ; + difference . + +ENDOP - ; + +THESAURUS OP - (THESAURUS CONST left, TEXT CONST right) : + + THESAURUS VAR difference := left ; + INT VAR index ; + delete (difference, right, index) ; + difference . + +ENDOP - ; + +THESAURUS OP / (THESAURUS CONST left, right) : + + THESAURUS VAR intersection := empty thesaurus ; + INT VAR index := 0 ; + get (left, name, index) ; + WHILE name <> "" REP + IF right CONTAINS name + THEN insert (intersection, name) + FI ; + get (left, name, index) + PER ; + intersection . + +ENDOP / ; + +THESAURUS OP ALL (TEXT CONST file name) : + + FILE VAR file := sequential file (input, file name) ; + THESAURUS VAR thesaurus := empty thesaurus ; + thesaurus FILLBY file ; + thesaurus . + +ENDOP ALL ; + +THESAURUS OP SOME (THESAURUS CONST thesaurus) : + + copy thesaurus into file ; + edit file ; + copy file into thesaurus . + +copy thesaurus into file : + forget (edit space) ; + edit space := nilspace ; + FILE VAR file := sequential file (output, edit space) ; + file FILLBY thesaurus . + +edit file : + modify (file) ; + edit (file) . + +copy file into thesaurus : + THESAURUS VAR result := empty thesaurus ; + input (file) ; + result FILLBY file ; + forget (edit space) ; + result . + +ENDOP SOME ; + +THESAURUS OP SOME (TASK CONST task) : + + SOME ALL task + +ENDOP SOME ; + +THESAURUS OP SOME (TEXT CONST file name) : + + SOME ALL file name + +ENDOP SOME ; + +THESAURUS OP LIKE (THESAURUS CONST thesaurus, TEXT CONST pattern) : + + THESAURUS VAR result:= empty thesaurus ; + INT VAR index:= 0 ; + REP get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE LIKE WITH result + ELIF name LIKE pattern + THEN insert (result, name) + FI + PER ; + result . + +ENDOP LIKE ; + +THESAURUS PROC remainder : + + remaining thesaurus + +ENDPROC remainder ; + +PROC do (PROC (TEXT CONST) operate, THESAURUS CONST thesaurus) : + + INT VAR index := 0 , operation number := 0 ; + TEXT VAR name ; + + remaining thesaurus := empty thesaurus ; + disable stop ; + work off thesaurus ; + fill leftover with remainder . + +work off thesaurus : + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE work off thesaurus + FI ; + operation number INCR 1 ; + cout (operation number) ; + execute (PROC (TEXT CONST) operate, name) + UNTIL is error ENDREP . + +fill leftover with remainder : + WHILE name <> "" REP + insert (remaining thesaurus, name) ; + get (thesaurus, name, index) + PER . + +ENDPROC do ; + +PROC execute (PROC (TEXT CONST) operate, TEXT CONST name) : + + enable stop ; + operate (name) + +ENDPROC execute ; + +PROC do (PROC (TEXT CONST, TASK CONST) operate, THESAURUS CONST thesaurus, + TASK CONST task) : + + INT VAR index := 0 , operation number := 0 ; + TEXT VAR name ; + + remaining thesaurus := empty thesaurus ; + disable stop ; + work off thesaurus ; + fill leftover with remainder . + +work off thesaurus : + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE work off thesaurus + FI ; + operation number INCR 1 ; + cout (operation number) ; + execute (PROC (TEXT CONST, TASK CONST) operate, name, task) + UNTIL is error ENDREP . + +fill leftover with remainder : + WHILE name <> "" REP + insert (remaining thesaurus, name) ; + get (thesaurus, name, index) + PER . + +ENDPROC do ; + +PROC execute (PROC (TEXT CONST, TASK CONST) operate, + TEXT CONST name, TASK CONST task) : + + enable stop ; + operate (name, task) + +ENDPROC execute ; + +OP FILLBY (THESAURUS VAR thesaurus, FILE VAR file) : + + WHILE NOT eof (file) REP + getline (file, name) ; + delete trailing blanks ; + IF name <> "" CAND NOT (thesaurus CONTAINS name) + THEN insert (thesaurus, name) + FI + PER . + +delete trailing blanks : + WHILE (name SUB LENGTH name) = " " REP + name := subtext (name, 1, LENGTH name - 1) + PER . + +ENDOP FILLBY ; + +OP FILLBY (FILE VAR file, THESAURUS CONST thesaurus) : + + INT VAR index := 0 ; + REP + get (thesaurus, name, index) ; + IF name = "" + THEN LEAVE FILLBY + FI ; + putline (file, name) + PER . + +ENDOP FILLBY ; + +OP FILLBY (TEXT CONST file name, THESAURUS CONST thesaurus) : + + FILE VAR f := sequential file (output, file name) ; + f FILLBY thesaurus + +ENDOP FILLBY ; + + + +PROC fetch (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) fetch, nameset) + +ENDPROC fetch ; + +PROC fetch (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) fetch, nameset, task) + +ENDPROC fetch ; + +PROC save (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) save, nameset) + +ENDPROC save ; + +PROC save (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) save, nameset, task) + +ENDPROC save ; + +PROC fetch all : + + fetch all (father) + +ENDPROC fetch all ; + +PROC fetch all (TASK CONST manager) : + + fetch (ALL manager, manager) + +ENDPROC fetch all ; + +PROC save all : + + save all (father) + +ENDPROC save all ; + +PROC save all (TASK CONST manager) : + + save (ALL myself, manager) + +ENDPROC save all ; + +PROC forget (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) forget, nameset) + +ENDPROC forget ; + +PROC erase (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) erase, nameset) + +ENDPROC erase ; + +PROC erase (THESAURUS CONST nameset, TASK CONST task) : + + do (PROC (TEXT CONST, TASK CONST) erase, nameset, task) + +ENDPROC erase ; + +PROC insert (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) insert, nameset) + +ENDPROC insert ; + +PROC edit (THESAURUS CONST nameset) : + + do (PROC (TEXT CONST) edit, nameset) + +ENDPROC edit ; + +ENDPACKET name set ; + -- cgit v1.2.3