~ubuntu-branches/debian/lenny/ucblogo/lenny

;;; -*- logo -*-

;;;

;;; .logo -- Logo initialization file (v.0.9.0)   Hrvoje Blazevic

;;;

 

;; Reversing 5.1 changes

;; Don't like getter/setter syntax "simplification". .LOOPS is

;; slow even without ALLOWGETSET. UNBURYONEDIT is meaningless

;; in logo-mode, and can possibly get in the way.

make "state.allowgetset :allowgetset

make "state.unburyonedit :unburyonedit

bury [[] [state.allowgetset state.unburyonedit] []]

erase [[] [allowgetset unburyonedit] []]

pr [ALLOWGETSET and UNBURYONEDIT disabled]

 

type "|loading LOOPS ... | wait 0

 

;; Allowing changes to Logo primitives

 

make "redefp "true

 

;; Preserving original definitions

 

copydef "if.tf "if                                                            

copydef "ifelse.tf "ifelse

copydef "not.tf "not

copydef "and.tf "and

copydef "or.tf "or

copydef "test.tf "test

 

;; Freeing names

 

erase [if ifelse not and or test]

 

 

;;; New definitions

 

.macro if :tf.val :run.true [:run.false []] 2

op (if.tf equalp :tf.val "false [:run.false] [:run.true])

end

 

.macro ifelse :tf.val :run.true :run.false

op (if.tf equalp :tf.val "false [:run.false] [:run.true])

end

 

to not :thing.not

op (if.tf equalp :thing.not "false ["true] ["false])

end

 

to true

op "true

end

 

to false

op "false

end

 

copydef "else "true

copydef "t "true

 

to and [:form.and ["true]] [:forms.and] 2

if.tf emptyp :forms.and [op run :form.and]

if run :form.and [op apply "and :forms.and]

op "false

end

 

to or [:form.or ["false]] [:forms.or] 2

if.tf emptyp :forms.or [op run :form.or]

cond.if run :form.or

op apply "or :forms.or

end

 

.macro cond.if :#cond.val

if :#cond.val [op list "op :#cond.val]

op []

end

 

to .and [:form.and ["true]] [:forms.and] 2

if.tf emptyp :forms.and [op first lput "#unspecified runresult :form.and]

if.tf not first lput "#unspecified runresult :form.and [op "false]

op apply ".and :forms.and

end

 

.macro test :any.value

op (list "test.tf "not.tf "not quoted :any.value)

end

 

;;; Extended prefix operators

 

copydef "difference.s "difference

copydef "quotient.s "quotient

 

erase [difference quotient equal? greater? less? before?]

 

to difference :first.num [:rest.nums] 2

if.tf emptyp :rest.nums [op minus :first.num]

op :first.num - (apply "sum :rest.nums)

end

 

to quotient :first.num [:rest.nums] 2

if.tf emptyp :rest.nums [op (1 / :first.num)]

op :first.num / (apply "product :rest.nums)

end

 

to equal? :elt [:rest] 2

op emptyp find [not.tf equalp ? :elt] :rest

end

 

to less? :elt [:nums] 2

if.tf emptyp :nums [op "true]

if.tf :elt < first :nums [op apply "less? :nums]

op "false

end

 

to greater? :elt [:nums] 2

if.tf emptyp :nums [op "true]

if.tf greaterp :elt first :nums [op apply "greater? :nums]

op "false

end

 

to before? :wd [:wds] 2

if.tf emptyp :wds [op "true]

if.tf beforep :wd first :wds [op apply "before? :wds]

op "false

end

 

to lesseq? :elt [:nums] 2

if.tf emptyp :nums [op "true]

if.tf :elt > first :nums [op "false]

op apply "lesseq? :nums

end

 

to greatereq? :elt [:nums] 2

if.tf emptyp :nums [op "true]

if.tf lessp :elt first :nums [op "false]

op apply "greatereq? :nums

end

 

to beforeq? :wd [:wds] 2

if.tf emptyp :wds [op "true]

if.tf beforep first :wds :wd [op "false]

op apply "beforeq? :wds

end

 

;;; Cleaning up

 

;; Prohibit further changes of primitives

ern "redefp

 

bury [if ifelse not true false else or and .and test cond.if]

bury [difference equal? greater? less? greatereq? lesseq? beforeq? quotient

                 before? difference.s quotient.s]

 

 

;;; Defining High Level Structures

 

;;; Letrec

 

.macro letrec :in.letrec

local [body.letrec method.&stack]

make "method.&stack []

make "body.letrec fput "dummy.letrec (list fput [] bf :in.letrec)

op insert.invoke letrec.helper lput :body.letrec first :in.letrec

end

 

to letrec.helper :clauses.letrec

if.tf emptyp :clauses.letrec [op (list "run [(dummy.letrec)])]

push "method.&stack first first :clauses.letrec

op (se "local (word "" first :method.&stack)

       "make (word "" first :method.&stack)

       bf first :clauses.letrec letrec.helper bf :clauses.letrec)

end

 

to insert.invoke :text 

if.tf emptyp :text [op []]

if.tf wordp first :text [

   op (or [(and [equalp first :text "\(]

                [memberp first bf :text :method.&stack]

                [(se first :text "invoke word ": first bf :text

                     insert.invoke bf bf :text)])]

          [se first :text insert.invoke  bf :text])]

op (if.tf listp first :text [fput insert.invoke runparse first :text

                                  insert.invoke bf :text]

          [fput first :text insert.invoke bf :text])

end

 

;;; Cond -- 2 versions

 

;; universal -- operation and command

.macro cond.ifelse :#cond.val :#cond.rest

op ifelse :#cond.val [(list :#cond.val)] [:#cond.rest]

end

 

.macro cond :cond.clauses

local [fclauses lclause]

make "lclause last :cond.clauses

(if.tf and [wordp first :lclause]

       [memberp first :lclause [else true t]]

       [make "lclause apply "se bf :lclause

             make "fclauses bl :cond.clauses]

       [make "fclauses :cond.clauses make "lclause ["#unspecified]])

op cond.helper :fclauses

end

 

to cond.helper :cond.clauses

if.tf emptyp :cond.clauses [op :lclause]

if.tf emptyp bf first :cond.clauses [

   op (se "cond.ifelse first first :cond.clauses

          (list cond.helper bf :cond.clauses))]

op (se "ifelse.tf first first :cond.clauses

       (list apply "se bf first :cond.clauses)

       (list cond.helper bf :cond.clauses))

end

 

;; command only -- slightly faster

.macro condc :cond.clauses

local [fclauses lclause]

make "lclause last :cond.clauses

(if.tf and [wordp first :lclause]

       [memberp first :lclause [else true t]]

       [make "lclause apply "se bf :lclause

             make "fclauses bl :cond.clauses]

       [make "fclauses :cond.clauses make "lclause ["#unspecified]])

op condc.helper :fclauses

end

 

to condc.helper :cond.clauses

if.tf emptyp :cond.clauses [op :lclause]

if.tf emptyp bf first :cond.clauses [

   op (se "cond.if first first :cond.clauses

          condc.helper bf :cond.clauses)]

op (se "if.tf first first :cond.clauses

       (list apply "se bf first :cond.clauses)

       condc.helper bf :cond.clauses)

end

 

;;; Case

 

;; universal -- operation and command, but *must* output a value

 

.macro case :case.clauses

local [fclauses lclause]

make "lclause last :case.clauses 

(if.tf and [wordp first :lclause]

       [memberp first :lclause [else true t]]

       [make "lclause apply "se bf :lclause

             make "fclauses bl bf :case.clauses]

       [make "fclauses bf :case.clauses make "lclause ["#unspecified]])

op (se (list "local ""#target "make ""#target "run first :case.clauses)

       case.helper :fclauses)

end

 

to case.helper :first.clauses

if.tf emptyp :first.clauses [op :lclause]

op (se "ifelse.tf "memberp ":#target

       (list first first :first.clauses) 

       (list apply "se bf first :first.clauses)

       (list case.helper bf :first.clauses))

end

 

;;; casec

 

;; command only -- mix code, true forms do not have to output

.macro casec :case.clauses

local [fclauses lclause]

make "lclause last :case.clauses 

(if.tf and [wordp first :lclause]

       [memberp first :lclause [else true t]]

       [make "lclause apply "se lput [op "#unspecified] bf :lclause

             make "fclauses bl bf :case.clauses]

       [make "fclauses bf :case.clauses make "lclause [op "#unspecified]])

op (se (list "local ""#target "make ""#target "run first :case.clauses)

       casec.helper :fclauses)

end

 

to casec.helper :first.clauses

if.tf emptyp :first.clauses [op :lclause]

op (se "ifelse.tf "memberp ":#target

       (list first first :first.clauses) 

       (list apply "se lput [op "#unspecified] bf first :first.clauses)

       (list casec.helper bf :first.clauses))

end

 

 

;;; Compiler -- source is commented out. Only the compiled code gets loaded.

 

; to loops.compiler [:proc procedures] 1

; letrec [[

;    [compile.proc [[proc]

;                   [if emptyp :proc [op []]]

;                   [local "struct.min]

;                   [op ifelse.tf

;                       (and [wordp first :proc]

;                            [macrop first :proc]

;                            [not gprop "compiler.cap first :proc]

;                            [not.tf emptyp bf :proc]

;                            [listp first bf :proc])

;                       [make "compiled "true

;                             se (list "run macroexpand list first :proc

;                                      (compile.proc first bf :proc))

;                             (compile.proc bf bf :proc)]

;                       [or [and [listp first :proc]

;                                [fput (compile.proc first :proc)

;                                      (compile.proc bf :proc)]]

;                           [fput first :proc (compile.proc bf :proc)]]]]]

;    [compile.ws [[proc.lst compiled]

;                 [if.tf emptyp :proc.lst [stop]]

;                 [.type (se "compiling  first :proc.lst "|... |)]

;                 [wait 0]

;                 [(invoke (or [and [macrop first :proc.lst]

;                                   [".defmacro]]

;                              ["define])

;                          first :proc.lst (compile.proc text first :proc.lst))]

;                 [.pr (if.tf :compiled

;                             [.and [pprop "compiled.procs first :proc.lst "true]

;                                   ["OK]]

;                             [(se [nothing to do for] first :proc.lst)])]

;                 [(compile.ws bf :proc.lst "false)]]]]

;         [ifelse listp :proc [(compile.ws filter "procedurep :proc "false)]

;                 [(compile.ws filter "procedurep (list :proc) "false)]]

;         [.pr [compilation completed]]]

; end

 

;;; Invoking the compiler from logo-mode with Compile Workspace

;;

;; Using ws.compile instead of loops.compiler

;; Filtering out all procedure names that end with .class

;; Compiling Class templates, firstly makes no sense, secondly,

;; will make Class unusable to the OBJECT.MAKER

;;

;;; ws.compile

 

to ws.compile

local "split

(loops.compiler

               filter

               [[x] [make "split split.word :x ".

                          op not (and [1 < count :split]

                                      [equalp last :split "class])]]

               procedures)

end

 

to compile.object :text

if.tf emptyp :text [op []]

if.tf (and [wordp first :text]

           [macrop first :text]

           [not gprop "compiler.cap first :text]

           [not.tf emptyp bf :text]

           [listp first bf :text]) ~

           [op se (list "run macroexpand list first :text

                        compile.object first bf :text)

               compile.object bf bf :text]

if.tf listp first :text ~

      [op fput compile.object first :text compile.object bf :text]

op fput first :text compile.object bf :text

end

 

to .type :text

if.tf :.verbose [type :text]

end

 

to .pr :text

if.tf :.verbose [pr :text]

end

 

;; specifying compiler output 

make ".verbose "true

 

;; Saving *only* compiled procedures. 

 

to save.compiled [:filename .and

                            [type "|Enter file name to save to: |]

                            [rw]] 1

if.tf namep "printwidthlimit ~

      [localmake "width :printwidthlimit ern "printwidthlimit]

if.tf namep "printdepthlimit ~

      [localmake "depth :printdepthlimit ern "printdepthlimit]

if equalp first :filename "" [make "filename bf :filename]

local "oldwriter

make "oldwriter writer

openwrite :filename

setwrite :filename

po (filter [[proc] [op not.tf emptyp gprop "compiled.procs :proc]]

           procedures)

setwrite :oldwriter

close :filename

if.tf namep "width [make "printwidthlimit :width]

if.tf namep "depth [make "printdepthlimit :depth]

end

 

 

;;; Compiler Capabilities

;;;

;;; Capabilities have this format: property = name of High Level Procedure

;;;                                value    = "false

;;;

;;; You can add your own compiler capabilities, providing you follow

;;; these rules: High level procedure (structure) you define must have

;;; one input only - a list. And, of-course it must be a macro --

;;; otherwise there is nothing for compiler to do. After you have

;;; defined (and tested) your procedure add your pprop line to lines

;;; below. That is all.

 

pprop "compiler.cap "letrec "false

pprop "compiler.cap "cond "false

pprop "compiler.cap "condc "false

pprop "compiler.cap "case "false

pprop "compiler.cap "casec "false

 

bury [[insert.invoke letrec letrec.helper cond cond.helper loops.compiler

                     compile.object save.compiled case .pr case.helper

                     casec casec.helper .type ws.compile condc condc.helper

                     cond.ifelse]

      [.verbose] [compiler.cap compiled.procs]]

 

;;; End of interpreter changes (.logo)

 

 

;;; Additions to Logo library 

 

to before :first.wd [:rest.wds] 2

if emptyp :rest.wds [op :first.wd]

if beforep first :rest.wds :first.wd [op apply "before :rest.wds]

op apply "before fput :first.wd bf :rest.wds

end

 

to max :first [:rest] 2

if emptyp :rest [op :first]

if greaterp :first first :rest [op apply "max fput :first bf :rest]

op apply "max :rest

end

 

to min :first [:rest] 2

if emptyp :rest [op :first]

if lessp :first first :rest [op apply "min fput :first bf :rest]

op apply "min :rest

end

 

to evenp :number

op zerop remainder :number 2

end

 

copydef "even? "evenp

 

to oddp :number

op not evenp :number

end

 

copydef "odd? "oddp

 

to zerop :number

op equalp :number 0

end

 

copydef "zero? "zerop

 

to identity :stuff

op :stuff

end

 

to last.pair :lst

if emptyp bf :lst [op :lst]

op last.pair bf :lst

end

 

to split.word :string [:delimiter "\ ] 2

local "result

if emptyp :string [op (list ")]

make "result split.word bf :string :delimiter

if equalp first :string :delimiter [op fput " :result]

op fput word first :string first :result bf :result

end

 

to time :instruction.list

localmake "start first first shell [date "+%s"]

pr runresult :instruction.list

(pr "Elapsed "time: (first first shell [date "+%s"]) - :start "seconds)

end

 

.macro begin :begin.forms

op apply "se :begin.forms

end

 

bury [before max min evenp even? oddp odd? zerop zero? identity last.pair

             split.word time begin]

 

;;; Restoring Standard Berkeley Logo

;;; This is of practical value only if used within Emacs logo-mode

 

to restore.standard

make "redefp "true

copydef "if "if.tf                                                     

copydef "ifelse "ifelse.tf

copydef "not "not.tf

copydef "and "and.tf

copydef "or "or.tf

copydef "test "test.tf

copydef "difference "difference.s

copydef "quotient "quotient.s

copydef "equal? "equalp

copydef "greater? "greaterp

copydef "less? "lessp

copydef "before? "beforep

;; .logo

make "allowgetset :state.allowgetset

make "unburyonedit :state.unburyonedit

bury [[] [allowgetset unburyonedit] []]

erase [

   [if.tf ifelse.tf not.tf and.tf or.tf test.tf false else t true .and

          insert.invoke letrec letrec.helper cond cond.helper cond.if

          cond.ifelse condc condc.helper loops.compiler ws.compile

          save.compiled case case.helper difference.s quotient.s lesseq?

          greatereq? beforeq? .type .pr casec casec.helper begin]

   [.verbose state.allowgetset state.unburyonedit]

   [compiler.cap compiled.procs]]

;; loops

erase [

   [object.maker static.make compile.object bucket.class base.object

                 counter.class send rewinding.counter.class container.class

                 stack.class delegate #self border.class browse.classes

                 circular.class double.end.class edit.classes indirect

                 inherit inherit.from insert.method insert.tree

                 inspect.methods.objects lambda list.class loops new

                 objects.group pair.class queue.class save.image send.helper

                 show.method.object static swap.pair.class word.class]

   [.accept.method loops.object.stack] [inheritance.tree]]

ern "redefp

gc ignore nodes gc ignore nodes gc

pr [Standard Berkeley Logo restored.]

end

 

bury [restore.standard loops.compiler]

 

 

;;; Compiled code

 

to loops.compiler [:proc procedures] 1

run [local "compile.proc make "compile.proc [[proc] [if emptyp :proc [op []]] [local "struct.min] [op ifelse.tf ( and [wordp first :proc] [macrop first :proc] [not gprop "compiler.cap first :proc] [not.tf emptyp bf :proc] [listp first bf :proc] ) [make "compiled "true se ( list "run macroexpand list first :proc ( invoke :compile.proc first bf :proc ) ) ( invoke :compile.proc bf bf :proc )] [or [and [listp first :proc] [fput ( invoke :compile.proc first :proc ) ( invoke :compile.proc bf :proc )]] [fput first :proc ( invoke :compile.proc bf :proc )]]]] local "compile.ws make "compile.ws [[proc.lst compiled] [if.tf emptyp :proc.lst [stop]] [.type ( se "compiling first :proc.lst "|... | )] [wait 0] [( invoke ( or [and [macrop first :proc.lst] [".defmacro]] ["define] ) first :proc.lst ( invoke :compile.proc text first :proc.lst ) )] [.pr ( if.tf :compiled [.and [pprop "compiled.procs first :proc.lst "true] ["OK]] [( se [nothing to do for] first :proc.lst )] )] [( invoke :compile.ws bf :proc.lst "false )]] local "dummy.letrec make "dummy.letrec [[] [ifelse listp :proc [( invoke :compile.ws filter "procedurep :proc "false )] [( invoke :compile.ws filter "procedurep ( list :proc ) "false )]] [.pr [compilation completed]]] run [( invoke :dummy.letrec )]]

end

 

type [Lisp layer OK ...]

 

 

;;; End of .logo