# Primitives are functions that are implemented directly in Mu. # They always evaluate all their arguments. fn initialize-primitives _self: (addr global-table) { var self/esi: (addr global-table) <- copy _self # for numbers append-primitive self, "+" append-primitive self, "-" append-primitive self, "*" append-primitive self, "/" append-primitive self, "%" append-primitive self, "sqrt" append-primitive self, "abs" append-primitive self, "sgn" append-primitive self, "<" append-primitive self, ">" append-primitive self, "<=" append-primitive self, ">=" # generic append-primitive self, "apply" append-primitive self, "=" append-primitive self, "no" append-primitive self, "not" append-primitive self, "dbg" append-primitive self, "len" # for pairs append-primitive self, "car" append-primitive self, "cdr" append-primitive self, "cons" append-primitive self, "cons?" # for screens append-primitive self, "print" append-primitive self, "clear" append-primitive self, "lines" append-primitive self, "columns" append-primitive self, "up" append-primitive self, "down" append-primitive self, "left" append-primitive self, "right" append-primitive self, "cr" append-primitive self, "pixel" append-primitive self, "line" append-primitive self, "hline" append-primitive self, "vline" append-primitive self, "circle" append-primitive self, "bezier" append-primitive self, "width" append-primitive self, "height" append-primitive self, "new_screen" append-primitive self, "blit" # for keyboards append-primitive self, "key" # for streams append-primitive self, "stream" append-primitive self, "write" append-primitive self, "read" append-primitive self, "rewind" # for arrays append-primitive self, "array" append-primitive self, "populate" append-primitive self, "index" append-primitive self, "iset" # for images append-primitive self, "img" # misc append-primitive self, "abort" # keep sync'd with render-primitives } # Slightly misnamed; renders primitives as well as special forms that don't # evaluate all their arguments. fn render-primitives screen: (addr screen), xmin: int, xmax: int, ymax: int { var y/ecx: int <- copy ymax y <- subtract 0x11/primitives-border clear-rect screen, xmin, y, xmax, ymax, 0xdc/bg=green-bg y <- increment var right-min/edx: int <- copy xmax right-min <- subtract 0x1e/primitives-divider set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "primitives", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " fn apply set if while", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "booleans", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " = and or not", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "lists", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " cons car cdr no cons? len", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "numbers", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " + - * / %", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " < > <= >=", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " sqrt abs sgn", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "arrays", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, " array index iset len", right-min, y, xmax, ymax, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy right-min tmpx <- draw-text-rightward screen, " populate", tmpx, xmax, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": int _ -> array", tmpx, xmax, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment set-cursor-position screen, right-min, y draw-text-wrapping-right-then-down-from-cursor screen, "images", right-min, y, xmax, ymax, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy right-min tmpx <- draw-text-rightward screen, " img", tmpx, xmax, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen stream x y w h", tmpx, xmax, y, 7/fg=grey, 0xdc/bg=green-bg #? { #? compare screen, 0 #? break-if-!= #? var foo/eax: byte <- read-key 0/keyboard #? compare foo, 0 #? loop-if-= #? } y <- copy ymax y <- subtract 0x10/primitives-border var left-max/edx: int <- copy xmax left-max <- subtract 0x20/primitives-divider var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, "cursor graphics", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " print", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen _ -> _", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " lines columns", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen -> number", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " up down left right", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " cr", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen ", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, "# move cursor down and to left margin", tmpx, left-max, y, 0x38/fg=trace, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, "pixel graphics", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " circle bezier line hline vline pixel", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " width height", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen -> number", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " clear", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": screen", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, "input", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " key", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": keyboard -> code-point-utf8?", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, "streams", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " stream", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": -> stream ", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " write", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": stream code-point-utf8 -> stream", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " rewind clear", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": stream", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg y <- increment var tmpx/eax: int <- copy xmin tmpx <- draw-text-rightward screen, " read", tmpx, left-max, y, 0x2a/fg=orange, 0xdc/bg=green-bg tmpx <- draw-text-rightward screen, ": stream -> code-point-utf8", tmpx, left-max, y, 7/fg=grey, 0xdc/bg=green-bg } fn primitive-global? _x: (addr global) -> _/eax: boolean { var x/eax: (addr global) <- copy _x var value-ah/eax: (addr handle cell) <- get x, value var value/eax: (addr cell) <- lookup *value-ah compare value, 0/null { break-if-!= return 0/false } var primitive?/eax: boolean <- primitive? value return primitive? } fn append-primitive _self: (addr global-table), name: (addr array byte) { var self/esi: (addr global-table) <- copy _self compare self, 0 { break-if-!= abort "append primitive" return } var final-index-addr/ecx: (addr int) <- get self, final-index increment *final-index-addr var curr-index/ecx: int <- copy *final-index-addr var data-ah/eax: (addr handle array global) <- get self, data var data/eax: (addr array global) <- lookup *data-ah var curr-offset/esi: (offset global) <- compute-offset data, curr-index var curr/esi: (addr global) <- index data, curr-offset var curr-name-ah/eax: (addr handle array byte) <- get curr, name copy-array-object name, curr-name-ah var curr-value-ah/eax: (addr handle cell) <- get curr, value new-primitive-function curr-value-ah, curr-index } # a little strange; goes from value to name and selects primitive based on name fn apply-primitive _f: (addr cell), args-ah: (addr handle cell), out: (addr handle cell), _globals: (addr global-table), trace: (addr trace) { var f/esi: (addr cell) <- copy _f var f-index-a/ecx: (addr int) <- get f, index-data var f-index/ecx: int <- copy *f-index-a var globals/eax: (addr global-table) <- copy _globals compare globals, 0 { break-if-!= abort "apply primitive" return } var global-data-ah/eax: (addr handle array global) <- get globals, data var global-data/eax: (addr array global) <- lookup *global-data-ah var f-offset/ecx: (offset global) <- compute-offset global-data, f-index var f-value/ecx: (addr global) <- index global-data, f-offset var f-name-ah/ecx: (addr handle array byte) <- get f-value, name var f-name/eax: (addr array byte) <- lookup *f-name-ah { var add?/eax: boolean <- string-equal? f-name, "+" compare add?, 0/false break-if-= apply-add args-ah, out, trace return } { var subtract?/eax: boolean <- string-equal? f-name, "-" compare subtract?, 0/false break-if-= apply-subtract args-ah, out, trace return } { var multiply?/eax: boolean <- string-equal? f-name, "*" compare multiply?, 0/false break-if-= apply-multiply args-ah, out, trace return } { var divide?/eax: boolean <- string-equal? f-name, "/" compare divide?, 0/false break-if-= apply-divide args-ah, out, trace return } # '%' is the remainder operator, because modulo isn't really meaningful for # non-integers # # I considered calling this operator 'rem', but I want to follow Arc in # using 'rem' for filtering out elements from lists. # https://arclanguage.github.io/ref/list.html#rem { var remainder?/eax: boolean <- string-equal? f-name, "%" compare remainder?, 0/false break-if-= apply-remainder args-ah, out, trace return } { var square-root?/eax: boolean <- string-equal? f-name, "sqrt" compare square-root?, 0/false break-if-= apply-square-root args-ah, out, trace return } { var abs?/eax: boolean <- string-equal? f-name, "abs" compare abs?, 0/false break-i
#
#
#           The Nim Compiler
#        (c) Copyright 2012 Andreas Rumpf
#
#    See the file "copying.txt", included in this
#    distribution, for details about the copyright.
#

## This module implements the merge operation of 2 different C files. This
## is needed for incremental compilation.

import
  ast, astalgo, ropes, options, strutils, nimlexbase, msgs, cgendata, rodutils,
  intsets, platform, llstream

# Careful! Section marks need to contain a tabulator so that they cannot
# be part of C string literals.

const
  CFileSectionNames: array[TCFileSection, string] = [
    cfsMergeInfo: "",
    cfsHeaders: "NIM_merge_HEADERS",
    cfsForwardTypes: "NIM_merge_FORWARD_TYPES",
    cfsTypes: "NIM_merge_TYPES",
    cfsSeqTypes: "NIM_merge_SEQ_TYPES",
    cfsFieldInfo: "NIM_merge_FIELD_INFO",
    cfsTypeInfo: "NIM_merge_TYPE_INFO",
    cfsProcHeaders: "NIM_merge_PROC_HEADERS",
    cfsData: "NIM_merge_DATA",
    cfsVars: "NIM_merge_VARS",
    cfsProcs: "NIM_merge_PROCS",
    cfsInitProc: "NIM_merge_INIT_PROC",
    cfsTypeInit1: "NIM_merge_TYPE_INIT1",
    cfsTypeInit2: "NIM_merge_TYPE_INIT2",
    cfsTypeInit3: "NIM_merge_TYPE_INIT3",
    cfsDebugInit: "NIM_merge_DEBUG_INIT",
    cfsDynLibInit: "NIM_merge_DYNLIB_INIT",
    cfsDynLibDeinit: "NIM_merge_DYNLIB_DEINIT",
  ]
  CProcSectionNames: array[TCProcSection, string] = [
    cpsLocals: "NIM_merge_PROC_LOCALS",
    cpsInit: "NIM_merge_PROC_INIT",
    cpsStmts: "NIM_merge_PROC_BODY"
  ]
  NimMergeEndMark = "/*\tNIM_merge_END:*/"

proc genSectionStart*(fs: TCFileSection): PRope =
  if compilationCachePresent:
    result = toRope(tnl)
    app(result, "/*\t")
    app(result, CFileSectionNames[fs])
    app(result, ":*/")
    app(result, tnl)

proc genSectionEnd*(fs: TCFileSection): PRope =
  if compilationCachePresent:
    result = toRope(NimMergeEndMark & tnl)

proc genSectionStart*(ps: TCProcSection): PRope =
  if compilationCachePresent:
    result = toRope(tnl)
    app(result, "/*\t")
    app(result, CProcSectionNames[ps])
    app(result, ":*/")
    app(result, tnl)

proc genSectionEnd*(ps: TCProcSection): PRope =
  if compilationCachePresent:
    result = toRope(NimMergeEndMark & tnl)

proc writeTypeCache(a: TIdTable, s: var string) =
  var i = 0
  for id, value in pairs(a):
    if i == 10:
      i = 0
      s.add(tnl)
    else:
      s.add(' ')
    encodeVInt(id, s)
    s.add(':')
    encodeStr(PRope(value).ropeToStr, s)
    inc i
  s.add('}')

proc writeIntSet(a: IntSet, s: var string) =
  var i = 0
  for x in items(a):
    if i == 10:
      i = 0
      s.add(tnl)
    else:
      s.add(' ')
    encodeVInt(x, s)
    inc i
  s.add('}')
  
proc genMergeInfo*(m: BModule): PRope =
  if optSymbolFiles notin gGlobalOptions: return nil
  var s = "/*\tNIM_merge_INFO:"
  s.add(tnl)
  s.add("typeCache:{")
  writeTypeCache(m.typeCache, s)
  s.add("declared:{")
  writeIntSet(m.declaredThings, s)
  s.add("typeInfo:{")
  writeIntSet(m.typeInfoMarker, s)
  s.add("labels:")
  encodeVInt(m.labels, s)
  s.add(" hasframe:")
  encodeVInt(ord(m.frameDeclared), s)
  s.add(tnl)
  s.add("*/")
  result = s.toRope

template `^`(pos: expr): expr = L.buf[pos]

proc skipWhite(L: var TBaseLexer) =
  var pos = L.bufpos
  while true:
    case ^pos
    of CR: pos = nimlexbase.handleCR(L, pos)
    of LF: pos = nimlexbase.handleLF(L, pos)
    of ' ': inc pos
    else: break
  L.bufpos = pos

proc skipUntilCmd(L: var TBaseLexer) =
  var pos = L.bufpos
  while true:
    case ^pos
    of CR: pos = nimlexbase.handleCR(L, pos)
    of LF: pos = nimlexbase.handleLF(L, pos)
    of '\0': break
    of '/': 
      if ^(pos+1) == '*' and ^(pos+2) == '\t':
        inc pos, 3
        break
      inc pos
    else: inc pos
  L.bufpos = pos

proc atEndMark(buf: cstring, pos: int): bool =
  var s = 0
  while s < NimMergeEndMark.len and buf[pos+s] == NimMergeEndMark[s]: inc s
  result = s == NimMergeEndMark.len

proc readVerbatimSection(L: var TBaseLexer): PRope = 
  var pos = L.bufpos
  var buf = L.buf
  var r = newStringOfCap(30_000)
  while true:
    case buf[pos]
    of CR:
      pos = nimlexbase.handleCR(L, pos)
      buf = L.buf
      r.add(tnl)
    of LF:
      pos = nimlexbase.handleLF(L, pos)
      buf = L.buf
      r.add(tnl)
    of '\0':
      internalError("ccgmerge: expected: " & NimMergeEndMark)
      break
    else: 
      if atEndMark(buf, pos):
        inc pos, NimMergeEndMark.len
        break
      r.add(buf[pos])
      inc pos
  L.bufpos = pos
  result = r.toRope

proc readKey(L: var TBaseLexer, result: var string) =
  var pos = L.bufpos
  var buf = L.buf
  setLen(result, 0)
  while buf[pos] in IdentChars:
    result.add(buf[pos])
    inc pos
  if buf[pos] != ':': internalError("ccgmerge: ':' expected")
  L.bufpos = pos + 1 # skip ':'

proc newFakeType(id: int): PType = 
  new(result)
  result.id = id

proc readTypeCache(L: var TBaseLexer, result: var TIdTable) =
  if ^L.bufpos != '{': internalError("ccgmerge: '{' expected")
  inc L.bufpos
  while ^L.bufpos != '}':
    skipWhite(L)
    var key = decodeVInt(L.buf, L.bufpos)
    if ^L.bufpos != ':': internalError("ccgmerge: ':' expected")
    inc L.bufpos
    var value = decodeStr(L.buf, L.bufpos)
    # XXX little hack: we create a "fake" type object with the correct Id
    # better would be to adapt the data structure to not even store the
    # object as key, but only the Id
    idTablePut(result, newFakeType(key), value.toRope)
  inc L.bufpos

proc readIntSet(L: var TBaseLexer, result: var IntSet) =
  if ^L.bufpos != '{': internalError("ccgmerge: '{' expected")
  inc L.bufpos
  while ^L.bufpos != '}':
    skipWhite(L)
    var key = decodeVInt(L.buf, L.bufpos)
    result.incl(key)
  inc L.bufpos

proc processMergeInfo(L: var TBaseLexer, m: BModule) =
  var k = newStringOfCap("typeCache".len)
  while true:
    skipWhite(L)
    if ^L.bufpos == '*' and ^(L.bufpos+1) == '/':
      inc(L.bufpos, 2)
      break
    readKey(L, k)
    case k
    of "typeCache": readTypeCache(L, m.typeCache)
    of "declared":  readIntSet(L, m.declaredThings)
    of "typeInfo":  readIntSet(L, m.typeInfoMarker)
    of "labels":    m.labels = decodeVInt(L.buf, L.bufpos)
    of "hasframe":  m.frameDeclared = decodeVInt(L.buf, L.bufpos) != 0
    else: internalError("ccgmerge: unknown key: " & k)

when not defined(nimhygiene):
  {.pragma: inject.}
  
template withCFile(cfilename: string, body: stmt) {.immediate.} = 
  var s = llStreamOpen(cfilename, fmRead)
  if s == nil: return
  var L {.inject.}: TBaseLexer
  openBaseLexer(L, s)
  var k {.inject.} = newStringOfCap("NIM_merge_FORWARD_TYPES".len)
  while true:
    skipUntilCmd(L)
    if ^L.bufpos == '\0': break
    body
  closeBaseLexer(L)
  
proc readMergeInfo*(cfilename: string, m: BModule) =
  ## reads the merge meta information into `m`.
  withCFile(cfilename):
    readKey(L, k)
    if k == "NIM_merge_INFO":
      processMergeInfo(L, m)
      break

type
  TMergeSections = object
    f: TCFileSections
    p: TCProcSections

proc readMergeSections(cfilename: string, m: var TMergeSections) =
  ## reads the merge sections into `m`.
  withCFile(cfilename):
    readKey(L, k)
    if k == "NIM_merge_INFO":   
      discard
    elif ^L.bufpos == '*' and ^(L.bufpos+1) == '/':
      inc(L.bufpos, 2)
      # read back into section
      skipWhite(L)
      var verbatim = readVerbatimSection(L)
      skipWhite(L)
      var sectionA = CFileSectionNames.find(k)
      if sectionA > 0 and sectionA <= high(TCFileSection).int:
        m.f[TCFileSection(sectionA)] = verbatim
      else:
        var sectionB = CProcSectionNames.find(k)
        if sectionB >= 0 and sectionB <= high(TCProcSection).int:
          m.p[TCProcSection(sectionB)] = verbatim
        else:
          internalError("ccgmerge: unknown section: " & k)
    else:
      internalError("ccgmerge: '*/' expected")

proc mergeRequired*(m: BModule): bool =
  for i in cfsHeaders..cfsProcs:
    if m.s[i] != nil:
      #echo "not empty: ", i, " ", ropeToStr(m.s[i])
      return true
  for i in low(TCProcSection)..high(TCProcSection):
    if m.initProc.s(i) != nil: 
      #echo "not empty: ", i, " ", ropeToStr(m.initProc.s[i])
      return true

proc mergeFiles*(cfilename: string, m: BModule) =
  ## merges the C file with the old version on hard disc.
  var old: TMergeSections
  readMergeSections(cfilename, old)
  # do the merge; old section before new section:    
  for i in low(TCFileSection)..high(TCFileSection):
    m.s[i] = con(old.f[i], m.s[i])
  for i in low(TCProcSection)..high(TCProcSection):
    m.initProc.s(i) = con(old.p[i], m.initProc.s(i))
f-= error trace, "'bezier' needs 8 args but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'bezier' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edi: (addr screen) <- copy _screen # x0 = args->right->left->value var rest-ah/eax: (addr handle cell) <- get args, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 1" return } var second-ah/eax: (addr handle cell) <- get rest, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 1/number break-if-= error trace, "second arg for 'bezier' is not a number (screen x coordinate of start point)" return } var second-value/eax: (addr float) <- get second, number-data var x0/edx: int <- convert *second-value # y0 = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 2" return } var third-ah/eax: (addr handle cell) <- get rest, left var third/eax: (addr cell) <- lookup *third-ah { var third-type/eax: (addr int) <- get third, type compare *third-type, 1/number break-if-= error trace, "third arg for 'bezier' is not a number (screen y coordinate of start point)" return } var third-value/eax: (addr float) <- get third, number-data var y0/ebx: int <- convert *third-value # x1 = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 3" return } var fourth-ah/eax: (addr handle cell) <- get rest, left var fourth/eax: (addr cell) <- lookup *fourth-ah { var fourth-type/eax: (addr int) <- get fourth, type compare *fourth-type, 1/number break-if-= error trace, "fourth arg for 'bezier' is not a number (screen x coordinate of control point)" return } var fourth-value/eax: (addr float) <- get fourth, number-data var tmp/eax: int <- convert *fourth-value var x1: int copy-to x1, tmp # y1 = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 4" return } var fifth-ah/eax: (addr handle cell) <- get rest, left var fifth/eax: (addr cell) <- lookup *fifth-ah { var fifth-type/eax: (addr int) <- get fifth, type compare *fifth-type, 1/number break-if-= error trace, "fifth arg for 'bezier' is not a number (screen y coordinate of control point)" return } var fifth-value/eax: (addr float) <- get fifth, number-data var tmp/eax: int <- convert *fifth-value var y1: int copy-to y1, tmp # x2 = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 3" return } var sixth-ah/eax: (addr handle cell) <- get rest, left var sixth/eax: (addr cell) <- lookup *sixth-ah { var sixth-type/eax: (addr int) <- get sixth, type compare *sixth-type, 1/number break-if-= error trace, "sixth arg for 'bezier' is not a number (screen x coordinate of end point)" return } var sixth-value/eax: (addr float) <- get sixth, number-data var tmp/eax: int <- convert *sixth-value var x2: int copy-to x2, tmp # y2 = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 4" return } var seventh-ah/eax: (addr handle cell) <- get rest, left var seventh/eax: (addr cell) <- lookup *seventh-ah { var seventh-type/eax: (addr int) <- get seventh, type compare *seventh-type, 1/number break-if-= error trace, "seventh arg for 'bezier' is not a number (screen y coordinate of end point)" return } var seventh-value/eax: (addr float) <- get seventh, number-data var tmp/eax: int <- convert *seventh-value var y2: int copy-to y2, tmp # color = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'bezier' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'bezier' needs 8 args but got 5" return } var eighth-ah/eax: (addr handle cell) <- get rest, left var eighth/eax: (addr cell) <- lookup *eighth-ah { var eighth-type/eax: (addr int) <- get eighth, type compare *eighth-type, 1/number break-if-= error trace, "eighth arg for 'bezier' is not an int (color; 0..0xff)" return } var eighth-value/eax: (addr float) <- get eighth, number-data var color/eax: int <- convert *eighth-value draw-monotonic-bezier screen, x0, y0, x1, y1, x2, y2, color # return nothing } fn apply-wait-for-key _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'key'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'key' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'key' needs 1 arg but got 0" return } # keyboard = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 6/keyboard break-if-= error trace, "first arg for 'key' is not a keyboard" return } var keyboard-ah/eax: (addr handle gap-buffer) <- get first, keyboard-data var _keyboard/eax: (addr gap-buffer) <- lookup *keyboard-ah var keyboard/ecx: (addr gap-buffer) <- copy _keyboard var result/eax: int <- wait-for-key keyboard # return key typed new-integer out, result } fn wait-for-key keyboard: (addr gap-buffer) -> _/eax: int { # if keyboard is 0, use real keyboard { compare keyboard, 0/real-keyboard break-if-!= var key/eax: byte <- read-key 0/real-keyboard var result/eax: int <- copy key return result } # otherwise read from fake keyboard var g/eax: code-point-utf8 <- read-from-gap-buffer keyboard var result/eax: int <- copy g return result } fn apply-stream _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply stream" allocate-stream out } fn apply-write _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'write'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'write' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'write' needs 2 args but got 0" return } # stream = args->left var first-ah/edx: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 3/stream break-if-= error trace, "first arg for 'write' is not a stream" return } var stream-data-ah/eax: (addr handle stream byte) <- get first, text-data var _stream-data/eax: (addr stream byte) <- lookup *stream-data-ah var stream-data/ebx: (addr stream byte) <- copy _stream-data # args->right->left var right-ah/eax: (addr handle cell) <- get args, right var right/eax: (addr cell) <- lookup *right-ah { var right-type/eax: (addr int) <- get right, type compare *right-type, 0/pair break-if-= error trace, "'write' encountered non-pair" return } { var nil?/eax: boolean <- nil? right compare nil?, 0/false break-if-= error trace, "'write' needs 2 args but got 1" return } var second-ah/eax: (addr handle cell) <- get right, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 1/number break-if-= error trace, "second arg for 'write' is not a number/code-point-utf8" return } var second-value/eax: (addr float) <- get second, number-data var x-float/xmm0: float <- copy *second-value var x/eax: int <- convert x-float var x-code-point-utf8/eax: code-point-utf8 <- copy x write-code-point-utf8 stream-data, x-code-point-utf8 # return the stream copy-object first-ah, out } fn apply-rewind _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'rewind'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'rewind' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'rewind' needs 1 arg but got 0" return } # stream = args->left var first-ah/edx: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 3/stream break-if-= error trace, "first arg for 'rewind' is not a stream" return } var stream-data-ah/eax: (addr handle stream byte) <- get first, text-data var _stream-data/eax: (addr stream byte) <- lookup *stream-data-ah var stream-data/ebx: (addr stream byte) <- copy _stream-data rewind-stream stream-data copy-object first-ah, out } fn apply-read _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'read'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'read' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'read' needs 1 arg but got 0" return } # stream = args->left var first-ah/edx: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 3/stream break-if-= error trace, "first arg for 'read' is not a stream" return } var stream-data-ah/eax: (addr handle stream byte) <- get first, text-data var _stream-data/eax: (addr stream byte) <- lookup *stream-data-ah var stream-data/ebx: (addr stream byte) <- copy _stream-data #? rewind-stream stream-data var result-code-point-utf8/eax: code-point-utf8 <- read-code-point-utf8 stream-data var result/eax: int <- copy result-code-point-utf8 new-integer out, result } fn apply-lines _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'lines'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'lines' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'lines' needs 1 arg but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'lines' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edx: (addr screen) <- copy _screen # compute dimensions var dummy/eax: int <- copy 0 var height/ecx: int <- copy 0 dummy, height <- screen-size screen var result/xmm0: float <- convert height new-float out, result } fn apply-columns _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'columns'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'columns' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'columns' needs 1 arg but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'columns' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edx: (addr screen) <- copy _screen # compute dimensions var width/eax: int <- copy 0 var dummy/ecx: int <- copy 0 width, dummy <- screen-size screen var result/xmm0: float <- convert width new-float out, result } fn apply-width _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'width'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'width' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'width' needs 1 arg but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'width' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edx: (addr screen) <- copy _screen # compute dimensions var width/eax: int <- copy 0 var dummy/ecx: int <- copy 0 width, dummy <- screen-size screen width <- shift-left 3/log2-font-width var result/xmm0: float <- convert width new-float out, result } fn apply-height _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'height'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'height' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'height' needs 1 arg but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'height' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edx: (addr screen) <- copy _screen # compute dimensions var dummy/eax: int <- copy 0 var height/ecx: int <- copy 0 dummy, height <- screen-size screen height <- shift-left 4/log2-font-height var result/xmm0: float <- convert height new-float out, result } fn apply-new-screen _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'screen'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'screen' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'screen' needs 2 args but got 0" return } # args->left->value var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 1/number break-if-= error trace, "first arg for 'screen' is not a number (screen width in pixels)" return } var first-value-a/ecx: (addr float) <- get first, number-data var first-value/ecx: int <- convert *first-value-a # args->right->left->value var right-ah/eax: (addr handle cell) <- get args, right var right/eax: (addr cell) <- lookup *right-ah { var right-type/eax: (addr int) <- get right, type compare *right-type, 0/pair break-if-= error trace, "'screen' encountered non-pair" return } { var nil?/eax: boolean <- nil? right compare nil?, 0/false break-if-= error trace, "'screen' needs 2 args but got 1" return } var second-ah/eax: (addr handle cell) <- get right, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 1/number break-if-= error trace, "second arg for 'screen' is not a number (screen height in pixels)" return } var second-value-a/edx: (addr float) <- get second, number-data var second-value/edx: int <- convert *second-value-a # create fake screen new-fake-screen out, first-value, second-value, 1/pixel-graphics } fn apply-blit _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'blit'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'blit' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'blit' needs 2 args but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'blit' is not a screen" return } var src-ah/eax: (addr handle screen) <- get first, screen-data var _src/eax: (addr screen) <- lookup *src-ah var src/ecx: (addr screen) <- copy _src # args->right->left var right-ah/eax: (addr handle cell) <- get args, right var right/eax: (addr cell) <- lookup *right-ah { var right-type/eax: (addr int) <- get right, type compare *right-type, 0/pair break-if-= error trace, "'blit' encountered non-pair" return } { var nil?/eax: boolean <- nil? right compare nil?, 0/false break-if-= error trace, "'blit' needs 2 args but got 1" return } var second-ah/eax: (addr handle cell) <- get right, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 5/screen break-if-= error trace, "second arg for 'blit' is not a screen" return } var dest-ah/eax: (addr handle screen) <- get second, screen-data var dest/eax: (addr screen) <- lookup *dest-ah # convert-screen-cells-to-pixels src copy-pixels src, dest } fn apply-array _args-ah: (addr handle cell), _out-ah: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'array'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'array' are not a list" return } var capacity/eax: int <- list-length args var out-ah/edi: (addr handle cell) <- copy _out-ah new-array out-ah, capacity var out/eax: (addr cell) <- lookup *out-ah var out-data-ah/eax: (addr handle array handle cell) <- get out, array-data var _out-data/eax: (addr array handle cell) <- lookup *out-data-ah var out-data/edi: (addr array handle cell) <- copy _out-data var i/ecx: int <- copy 0 { var done?/eax: boolean <- nil? args compare done?, 0/false break-if-!= var curr-ah/eax: (addr handle cell) <- get args, left var dest-ah/edx: (addr handle cell) <- index out-data, i copy-object curr-ah, dest-ah # update loop variables i <- increment var next-ah/eax: (addr handle cell) <- get args, right var next/eax: (addr cell) <- lookup *next-ah args <- copy next loop } } fn apply-populate _args-ah: (addr handle cell), _out-ah: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'populate'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'populate' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'populate' needs 2 args but got 0" return } # args->left var first-ah/ecx: (addr handle cell) <- get args, left # args->right->left var right-ah/eax: (addr handle cell) <- get args, right var right/eax: (addr cell) <- lookup *right-ah { var right-type/eax: (addr int) <- get right, type compare *right-type, 0/pair break-if-= error trace, "'populate' encountered non-pair" return } { var nil?/eax: boolean <- nil? right compare nil?, 0/false break-if-= error trace, "'populate' needs 2 args but got 1" return } var second-ah/edx: (addr handle cell) <- get right, left # var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 1/number break-if-= error trace, "first arg for 'populate' is not a number" return } var first-value/eax: (addr float) <- get first, number-data var capacity/ecx: int <- convert *first-value var out-ah/edi: (addr handle cell) <- copy _out-ah new-array out-ah, capacity var out/eax: (addr cell) <- lookup *out-ah var data-ah/eax: (addr handle array handle cell) <- get out, array-data var data/eax: (addr array handle cell) <- lookup *data-ah var i/ebx: int <- copy 0 { compare i, capacity break-if->= var curr-ah/ecx: (addr handle cell) <- index data, i copy-object second-ah, curr-ah i <- increment loop } } fn apply-index _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'index'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'index' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'index' needs 2 args but got 0" return } # args->left var first-ah/ecx: (addr handle cell) <- get args, left # args->right->left var right-ah/eax: (addr handle cell) <- get args, right var right/eax: (addr cell) <- lookup *right-ah { var right-type/eax: (addr int) <- get right, type compare *right-type, 0/pair break-if-= error trace, "'index' encountered non-pair" return } { var nil?/eax: boolean <- nil? right compare nil?, 0/false break-if-= error trace, "'index' needs 2 args but got 1" return } var second-ah/edx: (addr handle cell) <- get right, left # index var _first/eax: (addr cell) <- lookup *first-ah var first/ecx: (addr cell) <- copy _first { var first-type/eax: (addr int) <- get first, type compare *first-type, 7/array break-if-= error trace, "first arg for 'index' is not an array" return } var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 1/number break-if-= error trace, "second arg for 'index' is not a number" return } var second-value/eax: (addr float) <- get second, number-data var index/edx: int <- truncate *second-value var data-ah/eax: (addr handle array handle cell) <- get first, array-data var data/eax: (addr array handle cell) <- lookup *data-ah { var len/eax: int <- length data compare index, len break-if-< error trace, "index: too few elements in array" compare index, len { break-if-<= error trace, "foo" } return } var offset/edx: (offset handle cell) <- compute-offset data, index var src/eax: (addr handle cell) <- index data, offset copy-object src, out } fn apply-iset _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'iset'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'iset' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'iset' needs 3 args but got 0" return } # array = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 7/array break-if-= error trace, "first arg for 'iset' is not an array" return } var array-ah/eax: (addr handle array handle cell) <- get first, array-data var _array/eax: (addr array handle cell) <- lookup *array-ah var array/ecx: (addr array handle cell) <- copy _array # idx = args->right->left->value var rest-ah/eax: (addr handle cell) <- get args, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'iset' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'iset' needs 3 args but got 1" return } var second-ah/eax: (addr handle cell) <- get rest, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 1/number break-if-= error trace, "second arg for 'iset' is not an int (index)" return } var second-value/eax: (addr float) <- get second, number-data var idx/eax: int <- truncate *second-value # offset based on idx after bounds check var max/edx: int <- length array compare idx, max { break-if-< error trace, "iset: too few elements in array" return } var offset/edx: (offset handle cell) <- compute-offset array, idx # val = rest->right->left var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'iset' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'iset' needs 3 args but got 2" return } var val-ah/eax: (addr handle cell) <- get rest, left # copy var dest/edi: (addr handle cell) <- index array, offset copy-object val-ah, dest # return nothing } fn apply-render-image _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { trace-text trace, "eval", "apply 'img'" var args-ah/eax: (addr handle cell) <- copy _args-ah var _args/eax: (addr cell) <- lookup *args-ah var args/esi: (addr cell) <- copy _args { var args-type/eax: (addr int) <- get args, type compare *args-type, 0/pair break-if-= error trace, "args to 'img' are not a list" return } var empty-args?/eax: boolean <- nil? args compare empty-args?, 0/false { break-if-= error trace, "'img' needs 6 args but got 0" return } # screen = args->left var first-ah/eax: (addr handle cell) <- get args, left var first/eax: (addr cell) <- lookup *first-ah { var first-type/eax: (addr int) <- get first, type compare *first-type, 5/screen break-if-= error trace, "first arg for 'img' is not a screen" return } var screen-ah/eax: (addr handle screen) <- get first, screen-data var _screen/eax: (addr screen) <- lookup *screen-ah var screen/edi: (addr screen) <- copy _screen # x1 = args->right->left->value var rest-ah/eax: (addr handle cell) <- get args, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'img' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'img' needs 6 args but got 1" return } var second-ah/eax: (addr handle cell) <- get rest, left var second/eax: (addr cell) <- lookup *second-ah { var second-type/eax: (addr int) <- get second, type compare *second-type, 3/stream break-if-= error trace, "second arg for 'img' is not a stream (image data in ascii netpbm)" return } var img-data-ah/eax: (addr handle stream byte) <- get second, text-data var img-data/eax: (addr stream byte) <- lookup *img-data-ah var img-h: (handle cell) var img-ah/ecx: (addr handle cell) <- address img-h new-image img-ah, img-data # x = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'img' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'img' needs 6 args but got 2" return } var third-ah/eax: (addr handle cell) <- get rest, left var third/eax: (addr cell) <- lookup *third-ah { var third-type/eax: (addr int) <- get third, type compare *third-type, 1/number break-if-= error trace, "third arg for 'img' is not a number (screen x coordinate of top left)" return } var third-value/eax: (addr float) <- get third, number-data var x/ebx: int <- convert *third-value # y = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah var rest/esi: (addr cell) <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'img' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'img' needs 6 args but got 3" return } var fourth-ah/eax: (addr handle cell) <- get rest, left var fourth/eax: (addr cell) <- lookup *fourth-ah { var fourth-type/eax: (addr int) <- get fourth, type compare *fourth-type, 1/number break-if-= error trace, "fourth arg for 'img' is not a number (screen x coordinate of end point)" return } var fourth-value/eax: (addr float) <- get fourth, number-data var y/ecx: int <- convert *fourth-value # w = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'img' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'img' needs 6 args but got 4" return } var fifth-ah/eax: (addr handle cell) <- get rest, left var fifth/eax: (addr cell) <- lookup *fifth-ah { var fifth-type/eax: (addr int) <- get fifth, type compare *fifth-type, 1/number break-if-= error trace, "fifth arg for 'img' is not a number (screen y coordinate of end point)" return } var fifth-value/eax: (addr float) <- get fifth, number-data var tmp/eax: int <- convert *fifth-value var w: int copy-to w, tmp # h = rest->right->left->value var rest-ah/eax: (addr handle cell) <- get rest, right var _rest/eax: (addr cell) <- lookup *rest-ah rest <- copy _rest { var rest-type/eax: (addr int) <- get rest, type compare *rest-type, 0/pair break-if-= error trace, "'img' encountered non-pair" return } { var rest-nil?/eax: boolean <- nil? rest compare rest-nil?, 0/false break-if-= error trace, "'img' needs 6 args but got 5" return } var sixth-ah/eax: (addr handle cell) <- get rest, left var sixth/eax: (addr cell) <- lookup *sixth-ah { var sixth-type/eax: (addr int) <- get sixth, type compare *sixth-type, 1/number break-if-= error trace, "sixth arg for 'img' is not an int (height)" return } var sixth-value/eax: (addr float) <- get sixth, number-data var tmp/eax: int <- convert *sixth-value var h: int copy-to h, tmp # var img-cell-ah/eax: (addr handle cell) <- address img-h var img-cell/eax: (addr cell) <- lookup *img-cell-ah var img-ah/eax: (addr handle image) <- get img-cell, image-data var img/eax: (addr image) <- lookup *img-ah render-image screen, img, x y, w h # return nothing } fn apply-abort _args-ah: (addr handle cell), out: (addr handle cell), trace: (addr trace) { abort "aa" }